diff options
Diffstat (limited to '')
| -rw-r--r-- | cwality-config.toml | 9 | ||||
| -rw-r--r-- | cwality-maps/Config.hs | 61 | ||||
| -rw-r--r-- | cwality-maps/Main.hs | 175 | ||||
| -rw-r--r-- | package.yaml | 21 | ||||
| -rw-r--r-- | walint.cabal | 33 |
5 files changed, 296 insertions, 3 deletions
diff --git a/cwality-config.toml b/cwality-config.toml new file mode 100644 index 0000000..b663476 --- /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 0000000..1317f72 --- /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 0000000..8dde445 --- /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 53ef4c2..fa34022 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 cd79a59..738a748 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 |