little server for making cwality maps (which meow, for now)

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