Skip to content
Snippets Groups Projects
Select Git revision
  • 3bcc4a608e078733c210e8927421b255a6829cad
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

Main.hs

Blame
  • Main.hs 4.90 KiB
    {-# 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