From e730b8b904be35ebb21a26f788078de63207728c Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Thu, 3 Mar 2022 15:57:21 +0100
Subject: [PATCH] cwality-maps: add mustache templating
not going to be my faviourite templating language, but it seems to work
pretty well for this.
---
cwality-maps/Main.hs | 73 +++++------------------------
cwality-maps/Substitute.hs | 95 ++++++++++++++++++++++++++++++++++++++
package.yaml | 2 +
stack.yaml | 2 +
stack.yaml.lock | 7 +++
walint.cabal | 3 ++
6 files changed, 120 insertions(+), 62 deletions(-)
create mode 100644 cwality-maps/Substitute.hs
diff --git a/cwality-maps/Main.hs b/cwality-maps/Main.hs
index 8dde445..be2b0a6 100644
--- a/cwality-maps/Main.hs
+++ b/cwality-maps/Main.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@@ -24,12 +25,7 @@ import qualified Data.Aeson as A
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Text.Encoding.Base64.URL (decodeBase64Unpadded)
-import Data.Tiled (GlobalId, LocalId,
- Tiledmap)
-import GHC.Generics (Generic (Rep, from, to),
- K1 (K1), M1 (M1), U1,
- type (:*:) ((:*:)),
- type (:+:) (..))
+import Data.Tiled (Tiledmap)
import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort)
import Network.Wai.Middleware.Gzip (def)
@@ -40,12 +36,13 @@ import Servant (Application, Capture,
CaptureAll,
FromHttpApiData (parseUrlPiece),
Get, Handler, JSON, Raw,
- Server, err400,
- err404, serve,
- throwError,
+ Server, err400, err404,
+ serve, throwError,
type (:<|>) (..),
type (:>))
import Servant.Server.StaticFiles (serveDirectoryWebApp)
+import Substitute (Substitutable (substitute),
+ SubstitutionError)
-- | a map's filename ending in .json
-- (a newtype to differentiate between maps and assets in a route)
@@ -88,59 +85,8 @@ type Routes =
-class Substitutable s where
- substitute :: s -> Map Text Text -> s
-instance Substitutable Text where
- substitute orig subst = "meow" -- TODO: write a simple lexer to replace @vars@ or sth
-
-instance {-# OVERLAPS #-} Substitutable String where
- substitute orig substs = toString (substitute (toText orig) substs)
-
-instance {-# OVERLAPPING #-} (Functor a, Substitutable b) => Substitutable (a b) where
- substitute orig subst = map (`substitute` subst) orig
-
-instance {-# OVERLAPS #-} Substitutable A.Value where
- substitute = const
-
-instance Substitutable Int where
- substitute = const
-
-instance Substitutable GlobalId where
- substitute = const
-
-instance Substitutable LocalId where
- substitute = const
-
-instance Substitutable Double where
- substitute = const
-
-instance Substitutable Float where
- substitute = const
-
-class GSubstitutable i where
- gsubstitute :: i p -> Map Text Text -> i p
-
-instance Substitutable c => GSubstitutable (K1 i c) where
- gsubstitute (K1 text) = K1 . substitute text
-
-instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
- gsubstitute (a :*: b) substs = gsubstitute a substs :*: gsubstitute b substs
-
-instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
- gsubstitute (L1 a) = L1 . gsubstitute a
- gsubstitute (R1 a) = R1 . gsubstitute a
-
-instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
- gsubstitute (M1 a) = M1 . gsubstitute a
-
-instance GSubstitutable U1 where
- gsubstitute = const
-
-instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
- substitute a substs = to (gsubstitute (from a) substs)
-
-mkMap :: Config True -> Tiledmap -> MapParams -> Tiledmap
+mkMap :: Config True -> Tiledmap -> MapParams -> ([SubstitutionError], Tiledmap)
mkMap _config basemap params =
substitute basemap (substs params)
@@ -148,7 +94,10 @@ mkMap _config basemap params =
mapHandler :: Config True -> JsonFilename -> MapParams -> Handler Tiledmap
mapHandler config (JsonFilename mapname) params =
case M.lookup mapname (snd $ view template config) of
- Just basemap -> pure $ mkMap config basemap params
+ Just basemap -> do
+ let (errors, map) = mkMap config basemap params
+ print errors
+ pure map
Nothing -> throwError err404
-- | Complete set of routes: API + HTML sites
diff --git a/cwality-maps/Substitute.hs b/cwality-maps/Substitute.hs
new file mode 100644
index 0000000..65e8fc3
--- /dev/null
+++ b/cwality-maps/Substitute.hs
@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- | Typeclasses for (generic) substitution on all strings contained in an ADT,
+-- failsafe, but with error reporting
+module Substitute (SubstitutionError, Substitutable(..)) where
+
+import Universum
+
+import qualified Data.Aeson as A
+import qualified Data.Foldable as Fold
+import Data.Tiled (GlobalId, LocalId)
+import GHC.Generics (Generic (Rep, from, to), K1 (K1),
+ M1 (M1), U1, type (:*:) ((:*:)),
+ type (:+:) (..))
+import qualified Text.Mustache as MU
+import qualified Text.Mustache.Render as MU
+import Text.Parsec.Error (ParseError)
+
+-- | errors that might be encountered. SubstitutionErrors occur during substitution
+-- and a generally non-fatal (but might result e.g. in empty strings being inserted
+-- instead of variables), while CompileErrors may indicate that (invalid) template
+-- syntax got leaked into the output
+data SubstitutionError = CompileError ParseError | Mustache MU.SubstitutionError
+ deriving Show
+
+
+class Substitutable s where
+ substitute :: s -> Map Text Text -> ([SubstitutionError], s)
+
+instance Substitutable Text where
+ substitute orig substs = case MU.compileTemplate "" orig of
+ Right template -> first (map Mustache) $ MU.checkedSubstitute template substs
+ Left err -> ([CompileError err], orig) -- just ignore syntactic errors (TODO: add a log message?)
+
+
+instance {-# OVERLAPS #-} Substitutable String where
+ substitute orig substs = second toString (substitute (toText orig) substs)
+
+instance {-# OVERLAPPING #-} (Functor a, Substitutable b, Foldable a) => Substitutable (a b) where
+ substitute orig substs = (Fold.fold $ map fst orig',) $ map snd orig'
+ where orig' = map (`substitute` substs) orig
+
+-- | helper: don't substitute anything, don't produce errors
+trivial :: t -> b -> ([a], t)
+trivial = const . ([],)
+
+instance {-# OVERLAPS #-} Substitutable A.Value where
+ substitute = trivial
+
+instance Substitutable Int where
+ substitute = trivial
+
+instance Substitutable GlobalId where
+ substitute = trivial
+
+instance Substitutable LocalId where
+ substitute = trivial
+
+instance Substitutable Double where
+ substitute = trivial
+
+instance Substitutable Float where
+ substitute = trivial
+
+class GSubstitutable i where
+ gsubstitute :: i p -> Map Text Text -> ([SubstitutionError], i p)
+
+instance Substitutable c => GSubstitutable (K1 i c) where
+ gsubstitute (K1 text) = second K1 . substitute text
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
+ gsubstitute (a :*: b) substs = (e1 <> e2, a' :*: b')
+ where (e1, a') = gsubstitute a substs
+ (e2, b') = gsubstitute b substs
+
+instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
+ gsubstitute (L1 a) = second L1 . gsubstitute a
+ gsubstitute (R1 a) = second R1 . gsubstitute a
+
+instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
+ gsubstitute (M1 a) = second M1 . gsubstitute a
+
+instance GSubstitutable U1 where
+ gsubstitute = trivial
+
+instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
+ substitute a substs = second to (gsubstitute (from a) substs)
diff --git a/package.yaml b/package.yaml
index fa34022..2277d29 100644
--- a/package.yaml
+++ b/package.yaml
@@ -79,6 +79,8 @@ executables:
- filepath
- containers
- base64
+ - parsec
+ - mustache
walint-mapserver:
main: Main.hs
source-dirs: 'server'
diff --git a/stack.yaml b/stack.yaml
index dacc540..4448694 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -27,6 +27,8 @@ extra-deps:
- which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
- cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
- servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
+ # mustache is on stackage, but in a version that doesn't yet support aeson 2.0
+ - mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
allow-newer: true
# use aeson with a non-hash-floodable implementation
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 05aa1bc..54de1dd 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -81,6 +81,13 @@ packages:
sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3
original:
hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787
+- completed:
+ hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
+ pantry-tree:
+ size: 1182
+ sha256: 44c4d43ecfe1fee11fb03ffd49b0580ed00eec5144067092801ef4256df77ef8
+ original:
+ hackage: mustache-2.4.0@sha256:bd1cfbd027c04d8329877e95413d34dc357d4bee041dd8978cd6a23b114fbda1,3180
snapshots:
- completed:
size: 587393
diff --git a/walint.cabal b/walint.cabal
index 738a748..167a394 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -82,6 +82,7 @@ executable cwality-maps
main-is: Main.hs
other-modules:
Config
+ Substitute
Paths_walint
hs-source-dirs:
cwality-maps
@@ -98,6 +99,8 @@ executable cwality-maps
, filepath
, fmt
, microlens-platform
+ , mustache
+ , parsec
, servant
, servant-server
, text
--
GitLab