diff --git a/cwality-config.toml b/cwality-config.toml
new file mode 100644
index 0000000000000000000000000000000000000000..b663476c37a9fed2f1ebebc76ddc7de4c27c41eb
--- /dev/null
+++ b/cwality-config.toml
@@ -0,0 +1,9 @@
+
+
+verbose = true
+port = 8080
+
+# directory containing template maps.
+# all .json files therein will be interpreted as maps;
+# other files are served statically
+template = "./example-templates"
diff --git a/cwality-maps/Config.hs b/cwality-maps/Config.hs
new file mode 100644
index 0000000000000000000000000000000000000000..1317f72d2e53f2d57b98db6cb85258cc9709235d
--- /dev/null
+++ b/cwality-maps/Config.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Config ( loadConfig
+ , Config, port, verbose, template
+ ) where
+
+import Universum
+
+import Data.List (isSuffixOf)
+import qualified Data.Map.Strict as M
+import Data.Tiled (LoadResult (Loaded), Tiledmap,
+ loadTiledmap)
+import Lens.Micro.Platform (makeLenses, traverseOf)
+import System.Directory (listDirectory)
+import System.FilePath ((</>))
+import Toml (TomlCodec, (.=))
+import qualified Toml as T
+
+type family ConfigRes (b :: Bool) a where
+ ConfigRes True a = a
+ ConfigRes False a = FilePath
+
+-- | the server's configuration
+data Config (loaded :: Bool) = Config
+ { _port :: Int
+ , _verbose :: Bool
+ , _template :: ConfigRes loaded (FilePath, Map Text Tiledmap)
+ } deriving Generic
+
+makeLenses ''Config
+
+
+configCodec :: TomlCodec (Config False)
+configCodec = Config
+ <$> T.int "port" .= _port
+ <*> T.bool "verbose" .= _verbose
+ <*> T.string "template" .= _template
+
+loadConfig :: FilePath -> IO (Config True)
+loadConfig path = do
+ T.decodeFileEither configCodec path >>= \case
+ Right c -> traverseOf template loadMaps c
+ Left err -> error (show err)
+ where loadMaps path = do
+ maps <- listDirectory path
+ <&> filter (".json" `isSuffixOf`)
+
+ list <- forM maps $ \mapname ->
+ loadTiledmap (path </> mapname) >>= \case
+ Loaded tmap -> pure (toText mapname, tmap)
+ err -> error (show err)
+
+ pure (path, M.fromList list)
diff --git a/cwality-maps/Main.hs b/cwality-maps/Main.hs
new file mode 100644
index 0000000000000000000000000000000000000000..8dde44544c0ea8f26663f3572c09eed31e025b85
--- /dev/null
+++ b/cwality-maps/Main.hs
@@ -0,0 +1,175 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+-- | simple server offering linting "as a service"
+module Main where
+
+import Universum
+
+import Config (Config, loadConfig, port,
+ template, verbose)
+import Data.Aeson (FromJSON)
+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 Network.Wai.Handler.Warp (defaultSettings,
+ runSettings, setPort)
+import Network.Wai.Middleware.Gzip (def)
+import Network.Wai.Middleware.RequestLogger (OutputFormat (..),
+ RequestLoggerSettings (..),
+ mkRequestLogger)
+import Servant (Application, Capture,
+ CaptureAll,
+ FromHttpApiData (parseUrlPiece),
+ Get, Handler, JSON, Raw,
+ Server, err400,
+ err404, serve,
+ throwError,
+ type (:<|>) (..),
+ type (:>))
+import Servant.Server.StaticFiles (serveDirectoryWebApp)
+
+-- | a map's filename ending in .json
+-- (a newtype to differentiate between maps and assets in a route)
+newtype JsonFilename = JsonFilename Text
+
+instance FromHttpApiData JsonFilename where
+ parseUrlPiece url =
+ if ".json" `T.isSuffixOf` url
+ then Right (JsonFilename url)
+ else Left url
+
+
+newtype Tag = Tag Text
+ deriving (Generic, FromJSON)
+
+data MapParams = MapParams
+ { contentWarnings :: [Tag]
+ , backUrl :: Text
+ , exitUrl :: Maybe Text
+ , substs :: Map Text Text
+ } deriving (Generic, FromJSON)
+
+instance FromHttpApiData MapParams where
+ parseUrlPiece urltext =
+ case decodeBase64Unpadded urltext of
+ Right text -> case A.decode (encodeUtf8 text) of
+ Just params -> params
+ Nothing -> Left "decoding params failed?"
+ -- for fun (and testing) also allow non-encoded json
+ Left _err -> case A.decode (encodeUtf8 urltext) of
+ Just params -> Right params
+ Nothing -> Left "decoding MapParams failed"
+
+-- | actual set of routes: api for json & html + static pages from disk
+type Routes =
+ Capture "map.json" JsonFilename :> Capture "params" MapParams :> Get '[JSON] Tiledmap
+ -- explicitly capture broken json to return 400 instead of looking for files
+ :<|> Capture "map.json" JsonFilename :> CaptureAll "rest" Text :> Get '[JSON] Void
+ :<|> Raw
+
+
+
+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 basemap params =
+ substitute basemap (substs 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
+ Nothing -> throwError err404
+
+-- | Complete set of routes: API + HTML sites
+server :: Config True -> Server Routes
+server config = mapHandler config
+ :<|> (\_ _ -> throwError err400)
+ :<|> serveDirectoryWebApp (fst . view template $ config)
+
+app :: Config True -> Application
+app = serve (Proxy @Routes) . server
+
+main :: IO ()
+main = do
+ config <- loadConfig "./cwality-config.toml"
+ loggerMiddleware <- mkRequestLogger
+ $ def { outputFormat = Detailed (view verbose config) }
+
+ let warpsettings =
+ setPort (view port config)
+ defaultSettings
+
+ runSettings warpsettings
+ . loggerMiddleware
+ $ app config
diff --git a/package.yaml b/package.yaml
index 53ef4c28c1cc23bf7e636600805f08ce7d9744b6..fa34022bcd907ff661e0045592641f3adcd42145 100644
--- a/package.yaml
+++ b/package.yaml
@@ -61,13 +61,30 @@ executables:
- aeson-pretty
- template-haskell
- process
- walint-server:
+ cwality-maps:
+ main: Main.hs
+ source-dirs: 'cwality-maps'
+ ghc-options: -rtsopts -threaded
+ dependencies:
+ - tiled
+ - servant
+ - servant-server
+ - wai
+ - wai-extra
+ - warp
+ - fmt
+ - tomland
+ - microlens-platform
+ - directory
+ - filepath
+ - containers
+ - base64
+ walint-mapserver:
main: Main.hs
source-dirs: 'server'
ghc-options: -rtsopts -threaded
dependencies:
- walint
- - universum
- containers
- base-compat
- time
diff --git a/walint.cabal b/walint.cabal
index cd79a59d356b80b66fcdd953481e5cc2c8901668..738a748c7df2a9eac01ec0d5a3dc17c2e6f03aed 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -78,6 +78,37 @@ library tiled
, vector
default-language: Haskell2010
+executable cwality-maps
+ main-is: Main.hs
+ other-modules:
+ Config
+ Paths_walint
+ hs-source-dirs:
+ cwality-maps
+ default-extensions:
+ NoImplicitPrelude
+ ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -rtsopts -threaded
+ build-depends:
+ aeson
+ , base
+ , base64
+ , bytestring
+ , containers
+ , directory
+ , filepath
+ , fmt
+ , microlens-platform
+ , servant
+ , servant-server
+ , text
+ , tiled
+ , tomland
+ , universum
+ , wai
+ , wai-extra
+ , warp
+ default-language: Haskell2010
+
executable walint
main-is: Main.hs
other-modules:
@@ -101,7 +132,7 @@ executable walint
, walint
default-language: Haskell2010
-executable walint-server
+executable walint-mapserver
main-is: Main.hs
other-modules:
Handlers