diff options
Diffstat (limited to 'cwality-maps')
| -rw-r--r-- | cwality-maps/Main.hs | 73 | ||||
| -rw-r--r-- | cwality-maps/Substitute.hs | 95 |
2 files changed, 106 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) |