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

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