{-# LANGUAGE OverloadedStrings #-}

{-
  Copyright 2020 The CodeWorld Authors. All rights reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

module CodeWorld.Account.Actions
  ( createAccount,
    deleteAccount,
    storeExists,
    fetchAllAccounts,
    incrementTokenId,
    initStore,
    updateAccount,
    verifyPassword,
    verifyTokenId,
  )
where

import qualified CodeWorld.Account.Hashing as Hashing
import CodeWorld.Account.Types
import Control.Monad.Trans.State.Strict
  ( State,
    execState,
    modify,
  )
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as Text (intercalate, pack)
import Database.SQLite.Simple
  ( Connection,
    NamedParam (..),
    Only (..),
    Query (..),
    SQLData (..),
    execute,
    executeNamed,
    execute_,
    queryNamed,
    query_,
    withConnection,
    withTransaction,
  )
import Database.SQLite.Simple.ToField (ToField (..))
import System.Directory (doesFileExist)

type QueryParams = [(Text, SQLData)]

type QueryParamsBuilder = State QueryParams ()

withStore :: Store -> (Connection -> IO a) -> IO a
withStore (Store dbPath) = withConnection dbPath

storeExists :: Store -> IO Bool
storeExists (Store dbPath) = doesFileExist dbPath

initStore :: Store -> IO ()
initStore store = withStore store $ \conn -> do
  execute_ conn "DROP TABLE IF EXISTS accounts"
  execute_
    conn
    "CREATE TABLE IF NOT EXISTS accounts ( \
    \   id INTEGER PRIMARY KEY NOT NULL \
    \ , userId TEXT NOT NULL UNIQUE \
    \ , status TEXT NOT NULL \
    \ , passwordHash TEXT NOT NULL \
    \ , tokenId INTEGER NOT NULL \
    \)"

createAccount :: Store -> UserId -> Status -> PasswordHash -> IO ()
createAccount store (UserId userIdRaw) status (PasswordHash passwordHashRaw) =
  withStore store $ \conn ->
    execute
      conn
      "INSERT INTO accounts (userId, status, passwordHash, tokenId) VALUES (?, ?, ?, 0)"
      (userIdRaw, status, passwordHashRaw)

updateAccount :: Store -> UserId -> Maybe Status -> Maybe PasswordHash -> IO ()
updateAccount store (UserId userIdRaw) mbStatus mbPasswordHash =
  let params = buildParams $ do
        addParam mbStatus "status" toField
        addParam mbPasswordHash "passwordHash" (\(PasswordHash passwordHashRaw) -> SQLBlob passwordHashRaw)
      (q, ps) = renderInsert "accounts" "userId" (SQLText $ Text.pack userIdRaw) params
   in case ps of
        [_] -> pure ()
        _ -> withStore store $ \conn -> executeNamed conn q ps

deleteAccount :: Store -> UserId -> IO ()
deleteAccount store (UserId userIdRaw) =
  withStore store $ \conn ->
    executeNamed conn "DELETE FROM accounts WHERE userId = :userId" [":userId" := userIdRaw]

fetchAllAccounts :: Store -> IO [(UserId, Status, TokenId)]
fetchAllAccounts store =
  withStore store $ \conn -> do
    result <- query_ conn "SELECT userId, status, tokenId FROM accounts"
    return $ map (\(userIdRaw, status, tokenIdRaw) -> (UserId userIdRaw, status, TokenId tokenIdRaw)) result

verifyPassword :: Store -> UserId -> Password -> IO (Maybe Status)
verifyPassword store (UserId userIdRaw) password = do
  mbResult <- fetch
  case mbResult of
    Nothing -> pure Nothing
    Just (status, passwordHash) ->
      if Hashing.validate passwordHash password
        then pure $ Just status
        else pure Nothing
  where
    fetch :: IO (Maybe (Status, PasswordHash))
    fetch =
      withStore store $ \conn -> do
        result <-
          queryNamed
            conn
            "SELECT status, passwordHash FROM accounts WHERE userId = :userId"
            [":userId" := userIdRaw]
        case result of
          [(status, passwordHashRaw)] -> return $ Just (status, PasswordHash passwordHashRaw)
          [] -> return Nothing
          _ -> error "Assertion failure"

incrementTokenId :: Store -> UserId -> IO (Maybe TokenId)
incrementTokenId store (UserId userIdRaw) = withStore store $ \conn -> do
  result <- withTransaction conn $ do
    let params = [":userId" := userIdRaw]
    executeNamed
      conn
      "UPDATE accounts SET tokenId = tokenId + 1 WHERE userId = :userId"
      params
    queryNamed
      conn
      "SELECT tokenId FROM accounts WHERE userId = :userId"
      params
  case result of
    [(Only tokenIdRaw)] -> return $ Just (TokenId tokenIdRaw)
    [] -> return Nothing
    _ -> error "Assertion failure"

-- | Verifies that token ID is valid for active user
verifyTokenId ::
  -- | Account database configuration
  Store ->
  -- | User ID
  UserId ->
  -- | Token ID
  TokenId ->
  -- | True if valid, False otherwise
  IO Bool
verifyTokenId store (UserId userIdRaw) (TokenId tokenIdRaw) = withStore store $ \conn -> do
  let params =
        [ ":userId" := userIdRaw,
          ":tokenId" := tokenIdRaw
        ]
  result <-
    queryNamed
      conn
      "SELECT COUNT(*) FROM accounts WHERE userId = :userId AND tokenId = :tokenId AND status = 'Active'"
      params
  case result of
    [(Only count)] -> case (count :: Int) of
      0 -> return False
      1 -> return True
      _ -> error "Assertion failure"
    _ -> error "Assertion failure"

buildParams :: QueryParamsBuilder -> QueryParams
buildParams = (flip execState) []

addParam :: Maybe a -> Text -> (a -> SQLData) -> QueryParamsBuilder
addParam Nothing _ _ = pure ()
addParam (Just value) name f =
  modify
    (\items -> (name, f value) : items)

renderInsert :: Text -> Text -> SQLData -> QueryParams -> (Query, [NamedParam])
renderInsert tableName keyName keyValue params =
  let assignments = map (\(name, _) -> name <> " = :" <> name) params
      ps = (":" <> keyName := keyValue) : map (\(name, value) -> ":" <> name := value) params
   in ( Query $
          "UPDATE "
            <> tableName
            <> " SET "
            <> Text.intercalate ", " assignments
            <> " WHERE "
            <> keyName
            <> " = :"
            <> keyName,
        ps
      )
