Skip to content
Snippets Groups Projects
Commit e730b8b9 authored by stuebinm's avatar stuebinm
Browse files

cwality-maps: add mustache templating

not going to be my faviourite templating language, but it seems to work
pretty well for this.
parent 3fa02bb0
No related branches found
No related tags found
No related merge requests found
...@@ -6,6 +6,7 @@ ...@@ -6,6 +6,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
...@@ -24,12 +25,7 @@ import qualified Data.Aeson as A ...@@ -24,12 +25,7 @@ import qualified Data.Aeson as A
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding.Base64.URL (decodeBase64Unpadded) import Data.Text.Encoding.Base64.URL (decodeBase64Unpadded)
import Data.Tiled (GlobalId, LocalId, import Data.Tiled (Tiledmap)
Tiledmap)
import GHC.Generics (Generic (Rep, from, to),
K1 (K1), M1 (M1), U1,
type (:*:) ((:*:)),
type (:+:) (..))
import Network.Wai.Handler.Warp (defaultSettings, import Network.Wai.Handler.Warp (defaultSettings,
runSettings, setPort) runSettings, setPort)
import Network.Wai.Middleware.Gzip (def) import Network.Wai.Middleware.Gzip (def)
...@@ -40,12 +36,13 @@ import Servant (Application, Capture, ...@@ -40,12 +36,13 @@ import Servant (Application, Capture,
CaptureAll, CaptureAll,
FromHttpApiData (parseUrlPiece), FromHttpApiData (parseUrlPiece),
Get, Handler, JSON, Raw, Get, Handler, JSON, Raw,
Server, err400, Server, err400, err404,
err404, serve, serve, throwError,
throwError,
type (:<|>) (..), type (:<|>) (..),
type (:>)) type (:>))
import Servant.Server.StaticFiles (serveDirectoryWebApp) import Servant.Server.StaticFiles (serveDirectoryWebApp)
import Substitute (Substitutable (substitute),
SubstitutionError)
-- | a map's filename ending in .json -- | a map's filename ending in .json
-- (a newtype to differentiate between maps and assets in a route) -- (a newtype to differentiate between maps and assets in a route)
...@@ -88,59 +85,8 @@ type Routes = ...@@ -88,59 +85,8 @@ type Routes =
class Substitutable s where
substitute :: s -> Map Text Text -> s
instance Substitutable Text where mkMap :: Config True -> Tiledmap -> MapParams -> ([SubstitutionError], Tiledmap)
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 basemap params = mkMap _config basemap params =
substitute basemap (substs params) substitute basemap (substs params)
...@@ -148,7 +94,10 @@ mkMap _config basemap params = ...@@ -148,7 +94,10 @@ mkMap _config basemap params =
mapHandler :: Config True -> JsonFilename -> MapParams -> Handler Tiledmap mapHandler :: Config True -> JsonFilename -> MapParams -> Handler Tiledmap
mapHandler config (JsonFilename mapname) params = mapHandler config (JsonFilename mapname) params =
case M.lookup mapname (snd $ view template config) of 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 Nothing -> throwError err404
-- | Complete set of routes: API + HTML sites -- | Complete set of routes: API + HTML sites
......
{-# 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)
...@@ -79,6 +79,8 @@ executables: ...@@ -79,6 +79,8 @@ executables:
- filepath - filepath
- containers - containers
- base64 - base64
- parsec
- mustache
walint-mapserver: walint-mapserver:
main: Main.hs main: Main.hs
source-dirs: 'server' source-dirs: 'server'
......
...@@ -27,6 +27,8 @@ extra-deps: ...@@ -27,6 +27,8 @@ extra-deps:
- which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858 - which-0.2@sha256:db82ca7d83d64cce8ad579756f02d27c5bd289806ee02474726f7fafb87318e8,858
- cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122 - cli-git-0.1.0.2@sha256:4e62e6b7357e4fe698df8b58ba53919f9d4a056e9617dbc00c869a365e316387,1122
- servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 - 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 allow-newer: true
# use aeson with a non-hash-floodable implementation # use aeson with a non-hash-floodable implementation
......
...@@ -81,6 +81,13 @@ packages: ...@@ -81,6 +81,13 @@ packages:
sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3 sha256: 39e0e7b2b25980bfe4df036e89959188f9ef9e8c78c85e241fa9a682d1d78cf3
original: original:
hackage: servant-lucid-0.9.0.4@sha256:698db96903a145fdef40cc897f8790728642af917c37b941a98b2da872b65f08,1787 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: snapshots:
- completed: - completed:
size: 587393 size: 587393
......
...@@ -82,6 +82,7 @@ executable cwality-maps ...@@ -82,6 +82,7 @@ executable cwality-maps
main-is: Main.hs main-is: Main.hs
other-modules: other-modules:
Config Config
Substitute
Paths_walint Paths_walint
hs-source-dirs: hs-source-dirs:
cwality-maps cwality-maps
...@@ -98,6 +99,8 @@ executable cwality-maps ...@@ -98,6 +99,8 @@ executable cwality-maps
, filepath , filepath
, fmt , fmt
, microlens-platform , microlens-platform
, mustache
, parsec
, servant , servant
, servant-server , servant-server
, text , text
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment