{-# 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