{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}

module Main (main) where

import Relude

import Api (
  Api,
  AuthenticatedApi (..),
  AuthorizationHeader,
  OrganizationId,
  ProjectApi (..),
  ProjectId,
  RootApi (..),
  TicketApi (..),
  TicketId,
  TraceParentHeader,
 )
import Api qualified
import Authentication (
  AuthEnv (..),
  HasAuth (..),
  authenticateUser,
  getUserId,
 )
import Control.Exception (throwIO, try)
import Control.Monad.Logger (MonadLogger (..))
import Control.Monad.Logger.Aeson (Message ((:#)), logInfo, (.=))
import Control.Monad.Logger.Aeson qualified as Logger (defaultOutput)
import Data.Pool (Pool)
import Database (
  Connection,
  Database,
  DatabaseEnv (..),
  HasDatabase (..),
  createDbPool,
  query,
  runDatabase,
 )
import Logging (HasLogFunc (..), LogFunc, monadLoggerLogImpl)
import Network.HTTP.Client (
  defaultManagerSettings,
  managerConnCount,
  newManager,
 )
import Network.Wai.Handler.Warp qualified as Warp
import Organization (
  Organization (..),
  OrganizationService (..),
  createOrganizationServiceClient,
 )
import Servant (
  NamedRoutes,
  NoContent (..),
  ServerError (..),
  err404,
  err500,
  hoistServer,
  serve,
 )
import Servant qualified (Handler (..))
import Servant.Server qualified as Servant (layout)
import Servant.Server.Internal (AsServerT)
import Tracing (
  HasTracing (..),
  Tracer,
  TracingEnv (..),
  createNewSpan,
  createTracer,
  traced,
 )

-- App (Root)
-- ----------------------------------------------------------------------------

data Dependencies = Dependencies
  { dbPool :: Pool Connection
  , depsLogger :: LogFunc
  , tracer :: Tracer
  , authKey :: Text
  , organizationService :: OrganizationService
  }

data AppEnv = AppEnv
  { appLogger :: LogFunc
  , databaseEnv :: DatabaseEnv
  , tracingEnv :: TracingEnv
  }

newtype App a = App
  { unApp :: ReaderT AppEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppEnv
    )

instance MonadLogger App where
  monadLoggerLog = monadLoggerLogImpl

class (HasLogFunc env, HasDatabase env, HasTracing env) => HasApp env where
  getApp :: env -> AppEnv

instance HasApp AppEnv where
  getApp = identity

instance HasLogFunc AppEnv where
  getLogFunc = appLogger

instance HasDatabase AppEnv where
  getDatabase = databaseEnv

instance HasTracing AppEnv where
  getTracing = tracingEnv

runAppIO :: AppEnv -> App a -> IO a
runAppIO appEnv action = runReaderT (unApp action) appEnv

runAppServant
  :: AppEnv
  -> App a
  -> Servant.Handler a
runAppServant appEnv action =
  Servant.Handler . ExceptT . try $ runAppIO appEnv action

runApp :: Dependencies -> Maybe TraceParentHeader -> App a -> Servant.Handler a
runApp
  Dependencies {dbPool, depsLogger, tracer}
  maybeTraceParentHeader
  action = do
    activeSpan <- createNewSpan maybeTraceParentHeader >>= newIORef
    let tracingEnv =
          TracingEnv
            { tracer = tracer
            , activeSpan = activeSpan
            }
        databaseEnv =
          DatabaseEnv
            { dbLogger = depsLogger
            , connectionPool = dbPool
            }
        appEnv =
          AppEnv
            { appLogger = depsLogger
            , databaseEnv = databaseEnv
            , tracingEnv = tracingEnv
            }
    runAppServant appEnv action

server
  :: Dependencies
  -> Maybe TraceParentHeader
  -> RootApi (AsServerT Servant.Handler)
server deps maybeTraceParentHeader =
  hoistServer
    (Proxy @(NamedRoutes RootApi))
    (runApp deps maybeTraceParentHeader)
    (rootServer deps)

rootServer :: Dependencies -> RootApi (AsServerT App)
rootServer deps =
  RootApi
    { health = healthHandler
    , layout = layoutHandler
    , authenticatedApi = authenticatedServer'
    }
  where
    authenticatedServer' maybeAuthHeader =
      hoistServer
        (Proxy @(NamedRoutes AuthenticatedApi))
        (runAppAuthenticated (getDependenciesAuthenticated deps) maybeAuthHeader)
        (authenticatedServer maybeAuthHeader)

getDependenciesAuthenticated :: Dependencies -> DependenciesAuthenticated
getDependenciesAuthenticated Dependencies {authKey, organizationService} =
  DependenciesAuthenticated
    { authKey = authKey
    , organizationService = organizationService
    }

healthHandler :: App NoContent
healthHandler = pure NoContent

layoutHandler :: App Text
layoutHandler = pure $ Servant.layout (Proxy @Api)

-- AppAuthenticated
-- ----------------------------------------------------------------------------

data DependenciesAuthenticated = DependenciesAuthenticated
  { authKey :: Text
  , organizationService :: OrganizationService
  }

data AppAuthenticatedEnv = AppAuthenticatedEnv
  { appEnv :: AppEnv
  , authEnv :: AuthEnv
  , appOrganizationService :: OrganizationService
  }

newtype AppAuthenticated a = AppAuthenticated
  { unAppAuthenticated :: ReaderT AppAuthenticatedEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppAuthenticatedEnv
    )

instance MonadLogger AppAuthenticated where
  monadLoggerLog = monadLoggerLogImpl

class (HasApp env, HasAuth env) => HasAppAuthenticated env where
  getAppAuthenticated :: env -> AppAuthenticatedEnv

instance HasAppAuthenticated AppAuthenticatedEnv where
  getAppAuthenticated = identity

instance HasAuth AppAuthenticatedEnv where
  getAuth = authEnv

instance HasApp AppAuthenticatedEnv where
  getApp = appEnv

instance HasLogFunc AppAuthenticatedEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppAuthenticatedEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppAuthenticatedEnv where
  getTracing = getTracing . getApp

runAppAuthenticated
  :: DependenciesAuthenticated
  -> Maybe AuthorizationHeader
  -> AppAuthenticated a
  -> App a
runAppAuthenticated
  DependenciesAuthenticated {authKey, organizationService}
  maybeAuthHeader
  action = do
    userId <- authenticateUser authKey maybeAuthHeader
    let authEnv =
          AuthEnv
            { userId = userId
            }
        mapEnv appEnv' =
          AppAuthenticatedEnv
            { appEnv = appEnv'
            , authEnv = authEnv
            , appOrganizationService = organizationService
            }
    App $ withReaderT mapEnv (unAppAuthenticated action)

listOrganizationsHandler :: AppAuthenticated Api.ListOrganizationsResponse
listOrganizationsHandler = traced "list_organizations" $ do
  userId <- getUserId
  organizationService <- asks appOrganizationService
  organizations <- liftIO $ fetchUserOrganizations organizationService userId
  logInfo $
    "fetched organizations"
      :# [ "user_id" .= userId
         , "organizations" .= map organizationId organizations
         ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

authenticatedServer
  :: Maybe AuthorizationHeader
  -> AuthenticatedApi (AsServerT AppAuthenticated)
authenticatedServer _maybeAuthHeader =
  AuthenticatedApi
    { listOrganizations = listOrganizationsHandler
    , projectApi = projectServer'
    }
  where
    projectServer' organizationId =
      hoistServer
        (Proxy @(NamedRoutes ProjectApi))
        (runAppProject organizationId)
        (projectServer organizationId)

-- AppProject
-- ----------------------------------------------------------------------------

data Project = Project
  { projectId :: ProjectId
  , name :: Text
  }

data AppProjectEnv = AppProjectEnv
  { appAuthenticatedEnv :: AppAuthenticatedEnv
  , projectOrganization :: Organization
  }

newtype AppProject a = AppProject
  { unAppProject :: ReaderT AppProjectEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppProjectEnv
    )

instance MonadLogger AppProject where
  monadLoggerLog = monadLoggerLogImpl

class (HasAppAuthenticated env) => HasAppProject env where
  getAppProject :: env -> AppProjectEnv

instance HasAppProject AppProjectEnv where
  getAppProject = identity

instance HasAppAuthenticated AppProjectEnv where
  getAppAuthenticated = appAuthenticatedEnv

instance HasAuth AppProjectEnv where
  getAuth = getAuth . getAppAuthenticated

instance HasApp AppProjectEnv where
  getApp = getApp . getAppAuthenticated

instance HasLogFunc AppProjectEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppProjectEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppProjectEnv where
  getTracing = getTracing . getApp

runAppProject
  :: OrganizationId
  -> AppProject a
  -> AppAuthenticated a
runAppProject organizationId action = do
  organizationService <- asks appOrganizationService
  projectOrganization <-
    liftIO $
      fetchOrganization organizationService organizationId
  let mapEnv appAuthenticatedEnv' =
        AppProjectEnv
          { appAuthenticatedEnv = appAuthenticatedEnv'
          , projectOrganization = projectOrganization
          }
  AppAuthenticated $ withReaderT mapEnv (unAppProject action)

projectServer :: OrganizationId -> ProjectApi (AsServerT AppProject)
projectServer _organizationId =
  ProjectApi
    { createProject = createProjectHandler
    , getProject = getProjectHandler
    , ticketApi = ticketServer'
    }
  where
    ticketServer' projectId =
      hoistServer
        (Proxy @(NamedRoutes TicketApi))
        (runAppTicket projectId)
        (ticketServer projectId)

createProjectHandler
  :: Api.CreateProjectRequest -> AppProject Api.CreateProjectResponse
createProjectHandler projectName = traced "create_project" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  _ <-
    runDatabase $
      query
        "insert into projects (name, organization_id) values (?, ?) returning id"
        (projectName, organizationId)
  logInfo $
    "created project"
      :# [ "user_id" .= userId
         , "organization_id" .= organizationId
         ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getProjectHandler :: ProjectId -> AppProject Api.GetProjectResponse
getProjectHandler projectId = traced "get_project" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  _ <- runDatabase $ findProjectById projectId
  logInfo $
    "fetched project"
      :# [ "user_id" .= userId
         , "organization_id" .= organizationId
         ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getProjectOrganization
  :: (MonadReader env m, HasAppProject env) => m Organization
getProjectOrganization =
  asks (projectOrganization . getAppProject)

findProjectById :: ProjectId -> Database (Maybe Project)
findProjectById projectId = do
  _ <-
    query
      "select id, name from projects where id = ?"
      projectId
  pure . Just $
    Project
      { projectId = projectId
      , name = "My project"
      }

-- AppTicket
-- ----------------------------------------------------------------------------

data AppTicketEnv = AppTicketEnv
  { appProjectEnv :: AppProjectEnv
  , ticketProject :: Project
  }

newtype AppTicket a = AppTicket
  { unAppTicket :: ReaderT AppTicketEnv IO a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader AppTicketEnv
    )

instance MonadLogger AppTicket where
  monadLoggerLog = monadLoggerLogImpl

class (HasAppProject env) => HasAppTicket env where
  getAppTicket :: env -> AppTicketEnv

instance HasAppTicket AppTicketEnv where
  getAppTicket = identity

instance HasAppProject AppTicketEnv where
  getAppProject = appProjectEnv

instance HasAppAuthenticated AppTicketEnv where
  getAppAuthenticated = getAppAuthenticated . getAppProject

instance HasAuth AppTicketEnv where
  getAuth = getAuth . getAppAuthenticated

instance HasApp AppTicketEnv where
  getApp = getApp . getAppAuthenticated . getAppProject

instance HasLogFunc AppTicketEnv where
  getLogFunc = getLogFunc . getApp

instance HasDatabase AppTicketEnv where
  getDatabase = getDatabase . getApp

instance HasTracing AppTicketEnv where
  getTracing = getTracing . getApp

runAppTicket
  :: ProjectId
  -> AppTicket a
  -> AppProject a
runAppTicket projectId action = do
  let projectNotFound :: AppProject Project
      projectNotFound =
        liftIO $ throwIO $ err404 {errBody = "Project not found"}
  maybeProject <- runDatabase (findProjectById projectId)
  project <- maybe projectNotFound pure maybeProject
  let mapEnv appProjectEnv' =
        AppTicketEnv
          { appProjectEnv = appProjectEnv'
          , ticketProject = project
          }
  AppProject $ withReaderT mapEnv (unAppTicket action)

ticketServer :: ProjectId -> TicketApi (AsServerT AppTicket)
ticketServer _projectId =
  TicketApi
    { createTicket = createTicketHandler
    , getTicket = getTicketHandler
    }

createTicketHandler
  :: Api.CreateTicketRequest -> AppTicket Api.CreateTicketResponse
createTicketHandler ticketName = traced "create_ticket" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  projectId <- projectId <$> getTicketProject
  _ <-
    runDatabase $
      query
        "insert into tickets (name, project_id) values (?, ?) returning id"
        (ticketName, projectId)
  logInfo $
    "created ticket"
      :# [ "user_id" .= userId
         , "organization_id" .= organizationId
         , "project_id" .= projectId
         ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketHandler :: TicketId -> AppTicket Api.GetTicketResponse
getTicketHandler ticketId = traced "get_ticket" $ do
  userId <- getUserId
  organizationId <- organizationId <$> getProjectOrganization
  projectId <- projectId <$> getTicketProject
  _ <-
    runDatabase $
      query
        "select id, name from tickets where id = ?"
        ticketId
  logInfo $
    "fetched ticket"
      :# [ "user_id" .= userId
         , "organization_id" .= organizationId
         , "project_id" .= projectId
         ]
  liftIO $ throwIO $ err500 {errBody = "Not implemented"}

getTicketProject
  :: (MonadReader env m, HasAppTicket env) => m Project
getTicketProject =
  asks (ticketProject . getAppTicket)

-- Main
-- ----------------------------------------------------------------------------

main :: IO ()
main = do
  authKey <- toText . fromMaybe "abc123" <$> lookupEnv "AUTH_KEY"
  projectServiceUrl <-
    toText . fromMaybe "http://localhost:3001"
      <$> lookupEnv "PROJECT_SERVICE_URL"
  dbPool <- createDbPool "app:app@localhost:5432/app" 10
  tracer <- createTracer "app"
  httpManager <-
    newManager $
      defaultManagerSettings {managerConnCount = 20}
  let port = 3000
      dependencies =
        Dependencies
          { dbPool = dbPool
          , depsLogger = Logger.defaultOutput stdout
          , tracer = tracer
          , authKey = authKey
          , organizationService =
              createOrganizationServiceClient
                httpManager
                projectServiceUrl
          }
      waiApp = serve (Proxy @Api) (server dependencies)
  Warp.run port waiApp