summaryrefslogtreecommitdiff
path: root/cwality-maps
diff options
context:
space:
mode:
authorstuebinm2022-02-28 00:40:34 +0100
committerstuebinm2022-03-19 19:57:18 +0100
commit3fa02bb09b574bbccf9fc9faadb94f9c61d60e6c (patch)
treea661e50ac91df5b460aac614e3a8a1de57a6b0ba /cwality-maps
parent596096823872aaa491e1a208f70da820322a766f (diff)
little server for making cwality maps (which meow, for now)
Diffstat (limited to '')
-rw-r--r--cwality-maps/Config.hs61
-rw-r--r--cwality-maps/Main.hs175
2 files changed, 236 insertions, 0 deletions
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