diff options
author | stuebinm | 2022-10-11 11:28:30 +0200 |
---|---|---|
committer | stuebinm | 2022-10-11 11:28:30 +0200 |
commit | a29be8315c2e6647a5878529affda84ec8036ccb (patch) | |
tree | 9e5973c8e4a149dfcf2b20fcff6c08fe8c90fe59 /cwality-maps/Main.hs | |
parent | b6bc6c59c003cfbcfad2d5b1cf8809476f60fa17 (diff) |
update stack resolver
(also got rid of the map templater, which had version problems with
mustache — it's not likely anyone will need it anyways)
Diffstat (limited to '')
-rw-r--r-- | cwality-maps/Main.hs | 129 |
1 files changed, 0 insertions, 129 deletions
diff --git a/cwality-maps/Main.hs b/cwality-maps/Main.hs deleted file mode 100644 index 3f383cd..0000000 --- a/cwality-maps/Main.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# 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 (Tiledmap) -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) -import Substitute (Substitutable (substitute), - SubstitutionError) - -import Control.Monad.Logger - - --- | 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) - -newtype MapParams = MapParams - { 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 = - "generate" :> Capture "params" MapParams :> - (Capture "map.json" JsonFilename :> 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) - - - - -mkMap :: Config True -> Tiledmap -> MapParams -> ([SubstitutionError], Tiledmap) -mkMap _config basemap params = - substitute basemap (substs params) - -mapHandler :: MapParams -> Config True -> JsonFilename -> Handler Tiledmap -mapHandler params config (JsonFilename mapname) = - case M.lookup mapname (snd $ view template config) of - Just basemap -> runStdoutLoggingT $ - logWarnN (pretty errors) >> pure tiledmap - where (errors, tiledmap) = mkMap config basemap params - pretty errors = T.concat - . intersperse "\n " - $ concatMap (lines . show) errors - Nothing -> throwError err404 - --- | Complete set of routes: API + HTML sites -server :: Config True -> Server Routes -server config params = - mapHandler params 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 |