diff options
| -rw-r--r-- | cwality-maps/Main.hs | 73 | ||||
| -rw-r--r-- | cwality-maps/Substitute.hs | 95 | ||||
| -rw-r--r-- | package.yaml | 2 | ||||
| -rw-r--r-- | stack.yaml | 2 | ||||
| -rw-r--r-- | stack.yaml.lock | 7 | ||||
| -rw-r--r-- | walint.cabal | 3 |
6 files changed, 120 insertions, 62 deletions
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' @@ -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 |