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

5 files changed, 297 insertions, 4 deletions

diff --git a/cwality-config.toml b/cwality-config.toml
new file mode 100644
index 0000000..b663476
--- /dev/null
+++ b/cwality-config.toml
@@ -0,0 +1,9 @@
+
+
+verbose = true
+port = 8080
+
+# directory containing template maps.
+# all .json files therein will be interpreted as maps;
+# other files are served statically
+template = "./example-templates"
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
diff --git a/package.yaml b/package.yaml
index 53ef4c2..fa34022 100644
--- a/package.yaml
+++ b/package.yaml
@@ -61,13 +61,30 @@ executables:
       - aeson-pretty
       - template-haskell
       - process
-  walint-server:
+  cwality-maps:
+    main: Main.hs
+    source-dirs: 'cwality-maps'
+    ghc-options: -rtsopts -threaded
+    dependencies:
+      - tiled
+      - servant
+      - servant-server
+      - wai
+      - wai-extra
+      - warp
+      - fmt
+      - tomland
+      - microlens-platform
+      - directory
+      - filepath
+      - containers
+      - base64
+  walint-mapserver:
     main: Main.hs
     source-dirs: 'server'
     ghc-options: -rtsopts -threaded
     dependencies:
       - walint
-      - universum
       - containers
       - base-compat
       - time
diff --git a/walint.cabal b/walint.cabal
index 0bc387a..738a748 100644
--- a/walint.cabal
+++ b/walint.cabal
@@ -1,4 +1,4 @@
-cabal-version: 1.12
+cabal-version: 2.0
 
 -- This file has been generated from package.yaml by hpack version 0.34.5.
 --
@@ -78,6 +78,37 @@ library tiled
     , vector
   default-language: Haskell2010
 
+executable cwality-maps
+  main-is: Main.hs
+  other-modules:
+      Config
+      Paths_walint
+  hs-source-dirs:
+      cwality-maps
+  default-extensions:
+      NoImplicitPrelude
+  ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors -rtsopts -threaded
+  build-depends:
+      aeson
+    , base
+    , base64
+    , bytestring
+    , containers
+    , directory
+    , filepath
+    , fmt
+    , microlens-platform
+    , servant
+    , servant-server
+    , text
+    , tiled
+    , tomland
+    , universum
+    , wai
+    , wai-extra
+    , warp
+  default-language: Haskell2010
+
 executable walint
   main-is: Main.hs
   other-modules:
@@ -101,7 +132,7 @@ executable walint
     , walint
   default-language: Haskell2010
 
-executable walint-server
+executable walint-mapserver
   main-is: Main.hs
   other-modules:
       Handlers