summaryrefslogtreecommitdiff
path: root/cwality-maps/Main.hs
diff options
context:
space:
mode:
authorstuebinm2022-02-28 00:40:34 +0100
committerstuebinm2022-02-28 00:40:34 +0100
commit93ba7e10a5ccfa1c57fdd4242f8a459f25d105cb (patch)
tree77ba67fd64bedd8bd6514248019bd60410c5b185 /cwality-maps/Main.hs
parent8a201e8658c9365d301a7cda9077ddf005b014c9 (diff)
little server for making cwality maps (which meow, for now)
Diffstat (limited to 'cwality-maps/Main.hs')
-rw-r--r--cwality-maps/Main.hs175
1 files changed, 175 insertions, 0 deletions
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