summaryrefslogtreecommitdiff
path: root/cwality-maps
diff options
context:
space:
mode:
Diffstat (limited to 'cwality-maps')
-rw-r--r--cwality-maps/Config.hs61
-rw-r--r--cwality-maps/Main.hs129
-rw-r--r--cwality-maps/Substitute.hs100
3 files changed, 0 insertions, 290 deletions
diff --git a/cwality-maps/Config.hs b/cwality-maps/Config.hs
deleted file mode 100644
index 38c61ed..0000000
--- a/cwality-maps/Config.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-{-# 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 (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
- Right 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
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
diff --git a/cwality-maps/Substitute.hs b/cwality-maps/Substitute.hs
deleted file mode 100644
index ccab272..0000000
--- a/cwality-maps/Substitute.hs
+++ /dev/null
@@ -1,100 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-
--- | Typeclasses for (generic) substitution on all strings contained in an ADT,
--- failsafe, but with error reporting
-module Substitute (SubstitutionError, Substitutable(..)) where
-
-import Universum
-
-import qualified Data.Aeson as A
-import qualified Data.Foldable as Fold
-import Data.Tiled (GlobalId, LocalId)
-import GHC.Generics (Generic (Rep, from, to), K1 (K1),
- M1 (M1), U1, type (:*:) ((:*:)),
- type (:+:) (..))
-import qualified Text.Mustache as MU
-import qualified Text.Mustache.Render as MU
-import Text.Parsec.Error (ParseError)
-
--- | errors that might be encountered. SubstitutionErrors occur during substitution
--- and a generally non-fatal (but might result e.g. in empty strings being inserted
--- instead of variables), while CompileErrors may indicate that (invalid) template
--- syntax got leaked into the output
-data SubstitutionError = CompileError ParseError | Mustache MU.SubstitutionError
- deriving Show
-
-
-class Substitutable s where
- substitute :: s -> Map Text Text -> ([SubstitutionError], s)
-
-instance Substitutable Text where
- substitute orig substs = case MU.compileTemplate "" orig of
- Right template -> first (map Mustache) $ MU.checkedSubstitute template substs
- Left err -> ([CompileError err], orig) -- just ignore syntactic errors (TODO: add a log message?)
-
-
-instance {-# OVERLAPS #-} Substitutable String where
- substitute orig substs = second toString (substitute (toText orig) substs)
-
-instance {-# OVERLAPPING #-} (Functor a, Substitutable b, Foldable a) => Substitutable (a b) where
- substitute orig substs = (Fold.fold $ map fst orig',) $ map snd orig'
- where orig' = map (`substitute` substs) orig
-
--- | helper: don't substitute anything, don't produce errors
-trivial :: t -> b -> ([a], t)
-trivial = const . ([],)
-
-instance {-# OVERLAPS #-} Substitutable A.Value where
- substitute (A.Object fields) params =
- second A.Object $ traverse (`substitute` params) fields
- substitute (A.String str) params =
- second A.String $ substitute str params
- substitute other params = ([], other)
-
-
-instance Substitutable Int where
- substitute = trivial
-
-instance Substitutable GlobalId where
- substitute = trivial
-
-instance Substitutable LocalId where
- substitute = trivial
-
-instance Substitutable Double where
- substitute = trivial
-
-instance Substitutable Float where
- substitute = trivial
-
-class GSubstitutable i where
- gsubstitute :: i p -> Map Text Text -> ([SubstitutionError], i p)
-
-instance Substitutable c => GSubstitutable (K1 i c) where
- gsubstitute (K1 text) = second K1 . substitute text
-
-instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :*: b) where
- gsubstitute (a :*: b) substs = (e1 <> e2, a' :*: b')
- where (e1, a') = gsubstitute a substs
- (e2, b') = gsubstitute b substs
-
-instance (GSubstitutable a, GSubstitutable b) => GSubstitutable (a :+: b) where
- gsubstitute (L1 a) = second L1 . gsubstitute a
- gsubstitute (R1 a) = second R1 . gsubstitute a
-
-instance (GSubstitutable a) => GSubstitutable (M1 x y a) where
- gsubstitute (M1 a) = second M1 . gsubstitute a
-
-instance GSubstitutable U1 where
- gsubstitute = trivial
-
-instance {-# OVERLAPPABLE #-} (GSubstitutable (Rep a), Generic a) => Substitutable a where
- substitute a substs = second to (gsubstitute (from a) substs)
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-18 23:13:13 +0000