<commit_before>{-# LANGUAGE CPP               #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

module Hecate.Evaluator
  ( ModifyAction(..)
  , Verbosity(..)
  , Target(..)
  , Command(..)
  , Response(..)
  , setup
  , eval
  ) where

#ifdef BACKEND_JSON
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.List                as List
#endif

import           Data.Char                (toLower)
import           Data.Time.Clock          (UTCTime)
import           Prelude                  hiding (lookup)

import           Hecate.Data
import           Hecate.Interfaces


data ModifyAction = Keep | Change
  deriving (Show, Eq)

data Verbosity = Normal | Verbose
  deriving (Show, Eq)

data Target
  = TargetId Id
  | TargetDescription Description
  deriving (Show, Eq)

-- | 'Command' represents CLI commands
data Command
  = Add { addDescription :: Description
        , addIdentity    :: Maybe Identity
        , addMeta        :: Maybe Metadata
        }
  | Lookup { lookupDescription :: Description
           , lookupIdentity    :: Maybe Identity
           , lookupVerbosity   :: Verbosity
           }
  | ExportJSON { exportFile :: FilePath }
  | Modify { modifyTarget     :: Target
           , modifyCiphertext :: ModifyAction
           , modifyIdentity   :: Maybe Identity
           , modifyMeta       :: Maybe Metadata
           }
  | Redescribe { redescribeTarget      :: Target
               , redescribeDescription :: Description
               }
  | Remove { removeTarget :: Target }
  | CheckForMultipleKeys
  deriving Show

-- | 'Response' represents the response to a 'Command'
data Response
  = SingleEntry DisplayEntry Verbosity
  | MultipleEntries [DisplayEntry] Verbosity
  | Added
  | Exported
  | Modified
  | Redescribed
  | Removed
  | CheckedForMultipleKeys
  deriving (Show, Eq)

queryFromTarget :: Target -> Query
queryFromTarget (TargetId targetId)                   = MkQuery (Just targetId) Nothing Nothing Nothing
queryFromTarget (TargetDescription targetDescription) = MkQuery Nothing (Just targetDescription) Nothing Nothing

getSchemaVersionFromFile :: MonadInteraction m => FilePath -> m SchemaVersion
getSchemaVersionFromFile path = MkSchemaVersion . read <$> readFileAsString path

createSchemaFile :: MonadInteraction m => FilePath -> SchemaVersion -> m SchemaVersion
createSchemaFile path version = writeFileFromString path (show version) >> return version

getSchemaVersion :: (MonadInteraction m, MonadStore m) => FilePath -> m SchemaVersion
getSchemaVersion path = do
  fileExists <- doesFileExist path
  if fileExists
    then getSchemaVersionFromFile path
    else currentSchemaVersion >>= createSchemaFile path

reencryptAll :: (MonadEncrypt m, MonadStore m) => KeyId -> m ()
reencryptAll keyId = do
  entries        <- selectAll
  updatedEntries <- mapM reencrypt entries
  mapM_ put    updatedEntries
  mapM_ delete entries
  where
    reencrypt :: MonadEncrypt m => Entry -> m Entry
    reencrypt entry = do
      plaintext  <- decrypt $ entryCiphertext entry
      ciphertext <- encrypt keyId plaintext
      return $ mkEntry keyId
                       (entryTimestamp entry)
                       (entryDescription entry)
                       (entryIdentity entry)
                       ciphertext
                       (entryMeta entry)

initDatabase
  :: (MonadEncrypt m, MonadInteraction m, MonadStore m)
  => FilePath
  -> SchemaVersion
  -> KeyId
  -> m ()
initDatabase path schemaVersion keyId = do
  current <- currentSchemaVersion
  if schemaVersion == current
    then createTable
    else do message ("Migrating database from schema version "
                     ++ show schemaVersion
                     ++ " to version "
                     ++ show current
                     ++ "...")
            migrate schemaVersion keyId
            reencryptAll keyId
            _ <- createSchemaFile path current
            return ()

setup :: (MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m) => m ()
setup = do
  cfg <- askConfig
  let schemaFile = configSchemaFile cfg
      keyId      = configKeyId cfg
  schemaVersion <- getSchemaVersion schemaFile
  initDatabase schemaFile schemaVersion keyId

checkKey
  :: (MonadAppError m, MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m)
  => m Response
  -> m Response
checkKey k = do
  totalCount <- getCount
  if totalCount == 0
    then k
    else do cfg <- askConfig
            let keyId         = configKeyId cfg
                allowMultKeys = configAllowMultipleKeys cfg
                question      = "New keyid found: do you want to re-encrypt all entries?"
                err           = defaultError "You have set allow_multiple_keys to false"
            keyCount <- getCountOfKeyId keyId
            case (keyCount, allowMultKeys) of
              (0, False)                   -> yesNo question (reencryptAll keyId >> k) err
              (x, _    ) | x == totalCount -> k
              (_, True )                   -> yesNo question (reencryptAll keyId >> k) k
              (_, False)                   -> defaultError "All entries do not have the same keyid"
  where
    yesNo :: (MonadAppError m, MonadInteraction m) => String -> m a -> m a -> m a
    yesNo promptString kYes kNo = do
      input <- prompt (promptString ++ " [N/y] ")
      case map toLower input of
        ""  -> kNo
        "n" -> kNo
        "y" -> kYes
        _   -> defaultError "Please answer y or n"

add
  :: (MonadAppError m, MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m)
  => Description
  -> Maybe Identity
  -> Maybe Metadata
  -> m Response
add description maybeIdentity maybeMeta = checkKey $ do
  input      <- prompt "Enter text to encrypt: "
  timestamp  <- now
  keyId      <- configKeyId <$> askConfig
  ciphertext <- encrypt keyId $ mkPlaintext input
  put $ mkEntry keyId timestamp description maybeIdentity ciphertext maybeMeta
  return Added

lookup :: (MonadEncrypt m, MonadStore m) => Description -> Maybe Identity -> Verbosity -> m Response
lookup description maybeIdentity verbosity = do
  entries <- runQuery $ MkQuery Nothing (Just description) maybeIdentity Nothing
  case entries of
    []      -> return (MultipleEntries [] verbosity)
    [entry] -> SingleEntry     <$> f entry        <*> pure verbosity
    _       -> MultipleEntries <$> mapM f entries <*> pure verbosity
  where
    f :: MonadEncrypt m => Entry -> m DisplayEntry
    f MkEntry{entryId, entryTimestamp, entryDescription, entryIdentity, entryCiphertext, entryMeta} =
      do plaintext <- decrypt entryCiphertext
         return $ MkDisplayEntry entryId entryTimestamp entryDescription entryIdentity plaintext entryMeta

#ifdef BACKEND_JSON
exportJSON :: (MonadInteraction m, MonadStore m) => FilePath -> m Response
exportJSON jsonFile = do<commit_msg>Hecate.Evaluator: use ScopedTypeVariables<commit_after>{-# LANGUAGE CPP                 #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hecate.Evaluator
  ( ModifyAction(..)
  , Verbosity(..)
  , Target(..)
  , Command(..)
  , Response(..)
  , setup
  , eval
  ) where

#ifdef BACKEND_JSON
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.List                as List
#endif

import           Data.Char                (toLower)
import           Data.Time.Clock          (UTCTime)
import           Prelude                  hiding (lookup)

import           Hecate.Data
import           Hecate.Interfaces


data ModifyAction = Keep | Change
  deriving (Show, Eq)

data Verbosity = Normal | Verbose
  deriving (Show, Eq)

data Target
  = TargetId Id
  | TargetDescription Description
  deriving (Show, Eq)

-- | 'Command' represents CLI commands
data Command
  = Add { addDescription :: Description
        , addIdentity    :: Maybe Identity
        , addMeta        :: Maybe Metadata
        }
  | Lookup { lookupDescription :: Description
           , lookupIdentity    :: Maybe Identity
           , lookupVerbosity   :: Verbosity
           }
  | ExportJSON { exportFile :: FilePath }
  | Modify { modifyTarget     :: Target
           , modifyCiphertext :: ModifyAction
           , modifyIdentity   :: Maybe Identity
           , modifyMeta       :: Maybe Metadata
           }
  | Redescribe { redescribeTarget      :: Target
               , redescribeDescription :: Description
               }
  | Remove { removeTarget :: Target }
  | CheckForMultipleKeys
  deriving Show

-- | 'Response' represents the response to a 'Command'
data Response
  = SingleEntry DisplayEntry Verbosity
  | MultipleEntries [DisplayEntry] Verbosity
  | Added
  | Exported
  | Modified
  | Redescribed
  | Removed
  | CheckedForMultipleKeys
  deriving (Show, Eq)

queryFromTarget :: Target -> Query
queryFromTarget (TargetId targetId)                   = MkQuery (Just targetId) Nothing Nothing Nothing
queryFromTarget (TargetDescription targetDescription) = MkQuery Nothing (Just targetDescription) Nothing Nothing

getSchemaVersionFromFile :: MonadInteraction m => FilePath -> m SchemaVersion
getSchemaVersionFromFile path = MkSchemaVersion . read <$> readFileAsString path

createSchemaFile :: MonadInteraction m => FilePath -> SchemaVersion -> m SchemaVersion
createSchemaFile path version = writeFileFromString path (show version) >> return version

getSchemaVersion :: (MonadInteraction m, MonadStore m) => FilePath -> m SchemaVersion
getSchemaVersion path = do
  fileExists <- doesFileExist path
  if fileExists
    then getSchemaVersionFromFile path
    else currentSchemaVersion >>= createSchemaFile path

reencryptAll :: forall m. (MonadEncrypt m, MonadStore m) => KeyId -> m ()
reencryptAll keyId = do
  entries        <- selectAll
  updatedEntries <- mapM reencrypt entries
  mapM_ put    updatedEntries
  mapM_ delete entries
  where
    reencrypt :: Entry -> m Entry
    reencrypt entry = do
      plaintext  <- decrypt $ entryCiphertext entry
      ciphertext <- encrypt keyId plaintext
      return $ mkEntry keyId
                       (entryTimestamp entry)
                       (entryDescription entry)
                       (entryIdentity entry)
                       ciphertext
                       (entryMeta entry)

initDatabase
  :: (MonadEncrypt m, MonadInteraction m, MonadStore m)
  => FilePath
  -> SchemaVersion
  -> KeyId
  -> m ()
initDatabase path schemaVersion keyId = do
  current <- currentSchemaVersion
  if schemaVersion == current
    then createTable
    else do message ("Migrating database from schema version "
                     ++ show schemaVersion
                     ++ " to version "
                     ++ show current
                     ++ "...")
            migrate schemaVersion keyId
            reencryptAll keyId
            _ <- createSchemaFile path current
            return ()

setup :: (MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m) => m ()
setup = do
  cfg <- askConfig
  let schemaFile = configSchemaFile cfg
      keyId      = configKeyId cfg
  schemaVersion <- getSchemaVersion schemaFile
  initDatabase schemaFile schemaVersion keyId

checkKey
  :: forall m. (MonadAppError m, MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m)
  => m Response
  -> m Response
checkKey k = do
  totalCount <- getCount
  if totalCount == 0
    then k
    else do cfg <- askConfig
            let keyId         = configKeyId cfg
                allowMultKeys = configAllowMultipleKeys cfg
                question      = "New keyid found: do you want to re-encrypt all entries?"
                err           = defaultError "You have set allow_multiple_keys to false"
            keyCount <- getCountOfKeyId keyId
            case (keyCount, allowMultKeys) of
              (0, False)                   -> yesNo question (reencryptAll keyId >> k) err
              (x, _    ) | x == totalCount -> k
              (_, True )                   -> yesNo question (reencryptAll keyId >> k) k
              (_, False)                   -> defaultError "All entries do not have the same keyid"
  where
    yesNo :: String -> m a -> m a -> m a
    yesNo promptString kYes kNo = do
      input <- prompt (promptString ++ " [N/y] ")
      case map toLower input of
        ""  -> kNo
        "n" -> kNo
        "y" -> kYes
        _   -> defaultError "Please answer y or n"

add
  :: (MonadAppError m, MonadConfigReader m, MonadEncrypt m, MonadInteraction m, MonadStore m)
  => Description
  -> Maybe Identity
  -> Maybe Metadata
  -> m Response
add description maybeIdentity maybeMeta = checkKey $ do
  input      <- prompt "Enter text to encrypt: "
  timestamp  <- now
  keyId      <- configKeyId <$> askConfig
  ciphertext <- encrypt keyId $ mkPlaintext input
  put $ mkEntry keyId timestamp description maybeIdentity ciphertext maybeMeta
  return Added

lookup :: forall m. (MonadEncrypt m, MonadStore m) => Description -> Maybe Identity -> Verbosity -> m Response
lookup description maybeIdentity verbosity = do
  entries <- runQuery $ MkQuery Nothing (Just description) maybeIdentity Nothing
  case entries of
    []      -> return (MultipleEntries [] verbosity)
    [entry] -> SingleEntry     <$> f entry        <*> pure verbosity
    _       -> MultipleEntries <$> mapM f entries <*> pure verbosity
  where
    f :: Entry -> m DisplayEntry
    f MkEntry{entryId, entryTimestamp, entryDescription, entryIdentity, entryCiphertext, entryMeta} =
      do plaintext <- decrypt entryCiphertext
         return $ MkDisplayEntry entryId entryTimestamp entryDescription entryIdentity plaintext entryMeta

#ifdef BACKEND_JSON
exportJSON :: (MonadInteraction m, MonadStore m) => FilePath -> m Response
exportJSON jsonFile = do
{'fraction_non_alphanumeric': 0.07707940194512991, 'fraction_numerical': 0.00029031789809841774, 'mean_word_length': 2.3855036855036853, 'pattern_counts': {'":': 0, '<': 53, '<?xml version=': 0, '>': 120, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '6165648', 'n_tokens_mistral': 3788, 'n_tokens_neox': 3649, 'n_words': 1195}