{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Server.MonadIO.API where

import Control.Concurrent.STM
import Control.Monad.Except (ExceptT, runExceptT)
import Control.Monad.Reader (MonadReader, asks, runReaderT)
import Control.Monad.Trans (MonadIO, liftIO)
import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Trans.Reader (ReaderT)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.List (find)
import Data.Maybe (fromJust)
import Data.Morpheus (interpreter)
import Data.Morpheus.Document (importGQLDocument)
import Data.Morpheus.Types
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import Data.Tuple.Extra (both)
import Network.HTTP.Types (Status (..))
import Web.Scotty
import Prelude hiding (id)

importGQLDocument "src/Server/MonadIO/schema.graphql"

-------------------------------------------------------------------------------
data DogRow = DogRow
  { dogId :: Int,
    dogName :: Text,
    ownerId :: Int
  }

type DogTable = [DogRow]

data UserRow = UserRow
  { userId :: Int,
    userUsername :: Text,
    userPassword :: Text,
    userFullName :: Text
  }

type UserTable = [UserRow]

data FollowRow = FollowRow
  { followerId :: Int,
    followeeId :: Int
  }

type FollowTable = [FollowRow]

-------------------------------------------------------------------------------
data Database = Database
  { userTable :: UserTable,
    dogTable :: DogTable,
    followTable :: FollowTable
  }

dbInit :: Database
dbInit =
  Database
    { dogTable =
        [ DogRow 1 "Golden Retriever" 1, --
          DogRow 2 "Labrador" 3,
          DogRow 2 "Chihu" 1
        ],
      userTable =
        [ UserRow 1 "user1" "123" "Jon Snow",
          UserRow 2 "user2" "123" "Night King",
          UserRow 3 "user3" "123" "Arya Stark"
        ],
      followTable =
        [ FollowRow 1 2, --
          FollowRow 1 3
        ]
    }

tokenUser1 :: Text
tokenUser1 = "aGVsbG8gd29ybGQKZGFzZmFzZGZhZGY="

tokenUser2 :: Text
tokenUser2 = "ZaHsJld3fJhZGZkYXN2m239ZGFzZg=="

tokenUser3 :: Text
tokenUser3 = "ZGtzamZkbGFrc2pmZmRhZmVy223="

-------------------------------------------------------------------------------
type ErrorCode = Int

type Headers = [(Text, Text)] -- Could be anything

data Env = Env
  { database :: TVar Database,
    reqHeaders :: Headers
  }

newtype Web a = Web
  { runWeb :: ReaderT Env (ExceptT ErrorCode IO) a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadReader Env,
      MonadError Int,
      MonadIO
    )

-------------------------------------------------------------------------------

type RESOLVER t = (MonadTrans t, MonadIOResolver (t Web))

type RESTRICT o t = (MonadOperation (t Web) ~ o)

-- | Resolve value
type Value t (a :: k) = Flexible (t Web) a

-- | Resolve (f value)
type Wrapped t f (a :: k) = Composed (t Web) f a

-------------------------------------------------------------------------------
getDB :: (RESOLVER t) => Value t Database
getDB = do
  dbTVar <- lift $ asks database
  liftIO (readTVarIO dbTVar)

-------------------------------------------------------------------------------
requireAuthorized :: (RESOLVER t) => Value t Int
requireAuthorized = do
  reqHeaders <- lift $ asks reqHeaders
  case find ((== "Authorization") . fst) reqHeaders of
    Just (_, token)
      | token == tokenUser1 -> return 1
      | token == tokenUser2 -> return 2
      | token == tokenUser2 -> return 3
    _ -> fail "Unauthorized"

-------------------------------------------------------------------------------
rootResolver :: RootResolver Web () Query Mutation Undefined
rootResolver =
  defaultRootResolver
    { queryResolver = resolveQuery,
      mutationResolver = resolveMutation
    }

resolveMutation :: (RESOLVER t, RESTRICT MUTATION t) => Mutation (t Web)
resolveMutation = Mutation {addDog = addDogResolver}

resolveQuery :: (RESOLVER t, RESTRICT QUERY t) => Query (t Web)
resolveQuery =
  Query
    { login = loginResolver,
      getUser = getUserResolver,
      dogs = dogsResolver
    }

-------------------------------------------------------------------------------
loginResolver :: (RESOLVER t, RESTRICT QUERY t) => LoginArgs -> Wrapped t Maybe Session
loginResolver LoginArgs {username, password} = do
  users <- fmap userTable getDB
  let match user =
        userUsername user == username && userPassword user == password
  case find match users of
    Just userRow -> do
      let tokenUser
            | userId userRow == 1 = tokenUser1
            | userId userRow == 2 = tokenUser2
            | otherwise = tokenUser3
      pure
        $ Just
        $ Session {token = pure tokenUser, user = userResolver userRow}
    Nothing -> fail "Invalid user or password"

getUserResolver :: (RESOLVER t) => Arg "id" Int -> Wrapped t Maybe User
getUserResolver (Arg argId) = do
  _ <- requireAuthorized
  users <- fmap userTable getDB
  case find ((== argId) . userId) users of
    Just userRow -> do
      user <- userResolver userRow
      pure $ Just user
    _ -> pure Nothing

dogsResolver :: (RESOLVER t) => Wrapped t [] Dog
dogsResolver = do
  _ <- requireAuthorized
  dogs <- fmap dogTable getDB
  traverse dogResolver dogs

-------------------------------------------------------------------------------
addDogResolver :: (RESOLVER t, RESTRICT MUTATION t) => Arg "name" Text -> Value t Dog
addDogResolver (Arg name) = do
  currentUserId <- requireAuthorized
  db <- getDB
  let dogs = dogTable db
      nxtId = (+ 1) . maximum . fmap dogId $ dogs
      dogToAdd = DogRow nxtId name currentUserId
      newDogs = dogToAdd : dogs
      newDb = db {dogTable = newDogs}
  dbTVar <- lift $ asks database
  liftIO $ atomically $ writeTVar dbTVar newDb
  dogResolver dogToAdd

-------------------------------------------------------------------------------
userResolver :: (RESOLVER t) => UserRow -> Value t User
userResolver UserRow {userId = thisUserId, userFullName} =
  pure
    $ User
      { id = idResolver,
        name = nameResolver,
        favoriteDog = favoriteDogResolver,
        follows = followsResolver
      }
  where
    idResolver = pure thisUserId
    nameResolver = pure userFullName
    favoriteDogResolver :: (RESOLVER t) => Wrapped t Maybe Dog
    favoriteDogResolver = do
      dogs <- fmap dogTable getDB
      -- the 1st dog is the favorite dog
      case find ((== thisUserId) . ownerId) dogs of
        Just dogRow -> do
          dog <- dogResolver dogRow
          return . Just $ dog
        Nothing -> return Nothing
    followsResolver :: (RESOLVER t) => Wrapped t [] User
    followsResolver = do
      follows <- fmap followTable getDB
      users <- fmap userTable getDB
      let userFolloweeIds =
            map followeeId . filter ((== thisUserId) . followerId) $ follows
      let userFollowees = filter ((`elem` userFolloweeIds) . userId) users
      traverse userResolver userFollowees

dogResolver :: (RESOLVER t) => DogRow -> Value t Dog
dogResolver (DogRow dogId dogName ownerId) =
  pure $ Dog {id = idResolver, name = nameResolver, owner = ownerResolver}
  where
    idResolver = pure dogId
    nameResolver = pure dogName
    ownerResolver :: (RESOLVER t) => Value t User
    ownerResolver = do
      users <- fmap userTable getDB
      let userRow = fromJust . find ((== ownerId) . userId) $ users
      userResolver userRow

-------------------------------------------------------------------------------
api :: B.ByteString -> Web B.ByteString
api = interpreter rootResolver

app :: IO ()
app = do
  db <- newTVarIO dbInit
  scotty 8080
    $ post "/api"
    $ do
      reqBody <- body
      reqHeaders <- headers
      let env = Env db $ map (both $ T.pack . LT.unpack) reqHeaders
      res <-
        liftIO . runExceptT . flip runReaderT env . runWeb $ api reqBody
      case res of
        Left code -> status $ Status code "Error"
        Right rawResponse -> raw rawResponse
