<commit_before>{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Hecate.Types where

import Control.Monad.Except
import Control.Monad.Reader
import Crypto.Error (CryptoError (..))
import Crypto.Random.Entropy (getEntropy)
import Data.Aeson (ToJSON (..), FromJSON (..), genericToEncoding, defaultOptions)
import Data.Data
import Data.Text.Encoding
import Data.Time.Clock (UTCTime)
import Data.Time.Format
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField
import GHC.Generics
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Text as T
import qualified Database.SQLite.Simple as SQLite

newtype ByteString64 = ByteString64 { unByteString64 :: BS.ByteString }
  deriving (Eq, Ord, Data, Generic, Read, Typeable)

toBase64 :: BS.ByteString -> T.Text
toBase64 = decodeUtf8 . Base64.encode

instance Show ByteString64 where
  show (ByteString64 bs) = T.unpack (toBase64 bs)

instance ToJSON ByteString64 where
  toJSON (ByteString64 bs) =
    toJSON (toBase64 bs)

instance FromJSON ByteString64 where
  parseJSON o =
    parseJSON o >>= either fail (pure . ByteString64) . Base64.decode . encodeUtf8

instance ToField ByteString64 where
  toField (ByteString64 bs) = toField bs

instance FromField ByteString64 where
  fromField f = ByteString64 <$> fromField f

-- | A 'MasterPassword' is used, in conjunction with a 'Salt', to either
-- generate or verify a user's 'MasterKey'
newtype MasterPassword = MasterPassword T.Text
  deriving (Generic, Show)

instance ToJSON MasterPassword where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON MasterPassword

-- | A 'MasterKey' is a user's key, which is generated by calling
-- 'generateMasterKey' with a 'MasterPassword' and a 'Salt'.
newtype MasterKey = MasterKey ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON MasterKey where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON MasterKey

-- | A 'Salt' is a value that is used, in conjunction with a 'MasterPassword',
-- to generate a 'MasterKey'
newtype Salt = Salt ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON Salt where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Salt

makeSalt :: MonadIO m => Int -> m Salt
makeSalt len = Salt . ByteString64 <$> liftIO (getEntropy len)

-- | An 'Auth' is a record containing a 'MasterKey' and the 'Salt' that was used
-- to generate it
data Auth = Auth
  { key  :: MasterKey
  , salt :: Salt
  } deriving (Generic, Show, Eq)

instance ToJSON Auth where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Auth

-- | A 'PlainText' represents a decrypted value
newtype PlainText = PlainText T.Text
  deriving (Generic, Eq)

instance Show PlainText where
  show (PlainText t) = show t

instance ToJSON PlainText where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON PlainText

-- | A 'Nonce' is a value that is used, in conjunction with a 'MasterKey', to
-- encrypt and decrypt a given value
newtype Nonce = Nonce ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON Nonce where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Nonce

instance ToField Nonce where
  toField (Nonce bs) = toField bs

instance FromField Nonce where
  fromField f = Nonce <$> fromField f

makeNonce :: MonadIO m => m Nonce
makeNonce = Nonce . ByteString64 <$> liftIO (getEntropy 12)

-- | An 'AuthTag' is additional authenticated data that is used to verify the
-- integrity of a decrypted value
newtype AuthTag = AuthTag ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON AuthTag where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON AuthTag

instance ToField AuthTag where
  toField (AuthTag bs) = toField bs

instance FromField AuthTag where
  fromField f = AuthTag <$> fromField f

-- | A 'Description' identifies a given 'Entry'.  It could be a URI or a
-- descriptive name.
newtype Description = Description T.Text
  deriving (Generic, Eq)

instance Show Description where
  show (Description d) = show d

instance ToJSON Description where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Description

instance ToField Description where
  toField (Description bs) = toField bs

instance FromField Description where
  fromField f = Description <$> fromField f

-- | An 'Identity' represents an identifying value.  It could be the username in
-- a username/password pair
newtype Identity = Identity T.Text
  deriving (Generic, Eq)

instance Show Identity where
  show (Identity i) = show i

instance ToJSON Identity where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Identity

instance ToField Identity where
  toField (Identity bs) = toField bs

instance FromField Identity where
  fromField f = Identity <$> fromField f

-- | A 'CipherText' represents an encrypted value
newtype CipherText = CipherText ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON CipherText where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON CipherText

instance ToField CipherText where
  toField (CipherText bs) = toField bs

instance FromField CipherText where
  fromField f = CipherText <$> fromField f

-- | A 'Metadata' value contains additional non-specific information for a given
-- 'Entry'
newtype Metadata = Metadata T.Text
  deriving (Generic, Eq)

instance Show Metadata where
  show (Metadata m) = show m

instance ToJSON Metadata where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Metadata

instance ToField Metadata where
  toField (Metadata bs) = toField bs

instance FromField Metadata where
  fromField f = Metadata <$> fromField f

-- | An 'Entry' is a record that stores an encrypted value along with associated
-- information
data Entry = Entry
  { nonce       :: Nonce
  , authTag     :: AuthTag
  , timestamp   :: UTCTime
  , description :: Description
  , identity    :: Maybe Identity
  , cipherText  :: CipherText
  , meta        :: Maybe Metadata
  } deriving (Generic, Show, Eq)

instance ToJSON Entry where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Entry

instance SQLite.FromRow Entry where
  fromRow = Entry <$> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field

instance SQLite.ToRow Entry where
  toRow (Entry nce at ts d i ct m) =
    SQLite.toRow (nce, at, ts, d, i, ct, m)

-- | A 'DisplayEntry' is a record that is displayed to the user in response to a
-- command
data DisplayEntry = DisplayEntry
  { displayTimestamp   :: UTCTime
  , displayDescription :: Description
  , displayIdentity    :: Maybe Identity
  , displayPlainText   :: PlainText
  , displayMeta        :: Maybe Metadata
  } deriving Eq

showTime :: UTCTime -> String
showTime = formatTime defaultTimeLocale "%c"

instance Show DisplayEntry where
  show (DisplayEntry ts d (Just i) t (Just m)) =
    unwords [showTime ts, show d, show i, show t, show m]
  show (DisplayEntry ts d Nothing t (Just m)) =
    unwords [showTime ts, show d, show t, show m]
  show (DisplayEntry ts d (Just i) t Nothing) =
    unwords [showTime ts, show d, show i, show t]
  show (DisplayEntry ts d Nothing t Nothing) =
    unwords [showTime ts, show d, show t]

-- | A 'Query' represents a database query
data Query = Query
  { queryNonce       :: Maybe Nonce
  , queryDescription :: Maybe Description
  , queryIdentity    :: Maybe Identity
  , queryMeta        :: Maybe Metadata
  } deriving (Generic, Show, Eq)

instance ToJSON Query where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Query

newtype Ok = Ok { msg :: String }
  deriving (Generic, Show)

instance ToJSON Ok where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Ok

-- | 'AppError' represents application errors
data AppError
  = Base64Decoding String
  | JsonDecoding String
  | Crypto CryptoError
  | AuthVerification String
  | Integrity String
  | FileSystem String
  | Default String
  deriving (Show, Eq)

-- | 'AppContext' represents the shared environment for computations which occur
-- within an 'AppM'
data AppContext = AppContext
  { _authFile :: FilePath
  , _conn     :: SQLite.Connection
  }

-- | 'AppM' is the application monad
newtype AppM a = AppM { unAppM :: ReaderT AppContext (ExceptT AppError IO) a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadError AppError
           , MonadIO
           , MonadReader AppContext
           )

runAppM :: AppContext -> AppM a -> IO (Either AppError a)
runAppM ctx = runExceptT . flip runReaderT ctx . unAppM

-- | 'Command' represents CLI commands
data Command
  = Add { addDescription :: String
        , addIdentity    :: Maybe String
        , addMeta        :: Maybe String
        }
  | Remove { removeDescription :: String }
  | Lookup { lookupDescription :: String }
  deriving Show

-- | 'Response' represents the response to a 'Command'
data Response
  = SingleEntry DisplayEntry
  | MultipleEntries [DisplayEntry]
  | SinglePlainText PlainText
  | Added
  | Removed
  deriving (Eq)

instance Show Response where
  show (SingleEntry e)      = show e
  show (MultipleEntries es) = show es
  show (SinglePlainText p)  = show p
  show Added                = "added"
  show Removed              = "removed"
<commit_msg>store ByteString64 values in their Base64-encoded form<commit_after>{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Hecate.Types where

import Control.Monad.Except
import Control.Monad.Reader
import Crypto.Error (CryptoError (..))
import Crypto.Random.Entropy (getEntropy)
import Data.Aeson (ToJSON (..), FromJSON (..), genericToEncoding, defaultOptions)
import Data.Data
import Data.Text.Encoding
import Data.Time.Clock (UTCTime)
import Data.Time.Format
import Database.SQLite.Simple.FromField
import Database.SQLite.Simple.ToField
import GHC.Generics
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as Base64
import qualified Data.Text as T
import qualified Database.SQLite.Simple as SQLite

newtype ByteString64 = ByteString64 { unByteString64 :: BS.ByteString }
  deriving (Eq, Ord, Data, Generic, Read, Typeable)

toBase64 :: BS.ByteString -> T.Text
toBase64 = decodeUtf8 . Base64.encode

instance Show ByteString64 where
  show (ByteString64 bs) = T.unpack (toBase64 bs)

instance ToJSON ByteString64 where
  toJSON (ByteString64 bs) =
    toJSON (toBase64 bs)

instance FromJSON ByteString64 where
  parseJSON o =
    parseJSON o >>= either fail (pure . ByteString64) . Base64.decode . encodeUtf8

instance ToField ByteString64 where
  toField (ByteString64 bs) =
    toField (toBase64 bs)

instance FromField ByteString64 where
  fromField f =
    fromField f >>= either fail (pure . ByteString64) . Base64.decode . encodeUtf8

-- | A 'MasterPassword' is used, in conjunction with a 'Salt', to either
-- generate or verify a user's 'MasterKey'
newtype MasterPassword = MasterPassword T.Text
  deriving (Generic, Show)

instance ToJSON MasterPassword where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON MasterPassword

-- | A 'MasterKey' is a user's key, which is generated by calling
-- 'generateMasterKey' with a 'MasterPassword' and a 'Salt'.
newtype MasterKey = MasterKey ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON MasterKey where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON MasterKey

-- | A 'Salt' is a value that is used, in conjunction with a 'MasterPassword',
-- to generate a 'MasterKey'
newtype Salt = Salt ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON Salt where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Salt

makeSalt :: MonadIO m => Int -> m Salt
makeSalt len = Salt . ByteString64 <$> liftIO (getEntropy len)

-- | An 'Auth' is a record containing a 'MasterKey' and the 'Salt' that was used
-- to generate it
data Auth = Auth
  { key  :: MasterKey
  , salt :: Salt
  } deriving (Generic, Show, Eq)

instance ToJSON Auth where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Auth

-- | A 'PlainText' represents a decrypted value
newtype PlainText = PlainText T.Text
  deriving (Generic, Eq)

instance Show PlainText where
  show (PlainText t) = show t

instance ToJSON PlainText where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON PlainText

-- | A 'Nonce' is a value that is used, in conjunction with a 'MasterKey', to
-- encrypt and decrypt a given value
newtype Nonce = Nonce ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON Nonce where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Nonce

instance ToField Nonce where
  toField (Nonce bs) = toField bs

instance FromField Nonce where
  fromField f = Nonce <$> fromField f

makeNonce :: MonadIO m => m Nonce
makeNonce = Nonce . ByteString64 <$> liftIO (getEntropy 12)

-- | An 'AuthTag' is additional authenticated data that is used to verify the
-- integrity of a decrypted value
newtype AuthTag = AuthTag ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON AuthTag where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON AuthTag

instance ToField AuthTag where
  toField (AuthTag bs) = toField bs

instance FromField AuthTag where
  fromField f = AuthTag <$> fromField f

-- | A 'Description' identifies a given 'Entry'.  It could be a URI or a
-- descriptive name.
newtype Description = Description T.Text
  deriving (Generic, Eq)

instance Show Description where
  show (Description d) = show d

instance ToJSON Description where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Description

instance ToField Description where
  toField (Description bs) = toField bs

instance FromField Description where
  fromField f = Description <$> fromField f

-- | An 'Identity' represents an identifying value.  It could be the username in
-- a username/password pair
newtype Identity = Identity T.Text
  deriving (Generic, Eq)

instance Show Identity where
  show (Identity i) = show i

instance ToJSON Identity where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Identity

instance ToField Identity where
  toField (Identity bs) = toField bs

instance FromField Identity where
  fromField f = Identity <$> fromField f

-- | A 'CipherText' represents an encrypted value
newtype CipherText = CipherText ByteString64
  deriving (Generic, Show, Eq)

instance ToJSON CipherText where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON CipherText

instance ToField CipherText where
  toField (CipherText bs) = toField bs

instance FromField CipherText where
  fromField f = CipherText <$> fromField f

-- | A 'Metadata' value contains additional non-specific information for a given
-- 'Entry'
newtype Metadata = Metadata T.Text
  deriving (Generic, Eq)

instance Show Metadata where
  show (Metadata m) = show m

instance ToJSON Metadata where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Metadata

instance ToField Metadata where
  toField (Metadata bs) = toField bs

instance FromField Metadata where
  fromField f = Metadata <$> fromField f

-- | An 'Entry' is a record that stores an encrypted value along with associated
-- information
data Entry = Entry
  { nonce       :: Nonce
  , authTag     :: AuthTag
  , timestamp   :: UTCTime
  , description :: Description
  , identity    :: Maybe Identity
  , cipherText  :: CipherText
  , meta        :: Maybe Metadata
  } deriving (Generic, Show, Eq)

instance ToJSON Entry where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Entry

instance SQLite.FromRow Entry where
  fromRow = Entry <$> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field
                  <*> SQLite.field

instance SQLite.ToRow Entry where
  toRow (Entry nce at ts d i ct m) =
    SQLite.toRow (nce, at, ts, d, i, ct, m)

-- | A 'DisplayEntry' is a record that is displayed to the user in response to a
-- command
data DisplayEntry = DisplayEntry
  { displayTimestamp   :: UTCTime
  , displayDescription :: Description
  , displayIdentity    :: Maybe Identity
  , displayPlainText   :: PlainText
  , displayMeta        :: Maybe Metadata
  } deriving Eq

showTime :: UTCTime -> String
showTime = formatTime defaultTimeLocale "%c"

instance Show DisplayEntry where
  show (DisplayEntry ts d (Just i) t (Just m)) =
    unwords [showTime ts, show d, show i, show t, show m]
  show (DisplayEntry ts d Nothing t (Just m)) =
    unwords [showTime ts, show d, show t, show m]
  show (DisplayEntry ts d (Just i) t Nothing) =
    unwords [showTime ts, show d, show i, show t]
  show (DisplayEntry ts d Nothing t Nothing) =
    unwords [showTime ts, show d, show t]

-- | A 'Query' represents a database query
data Query = Query
  { queryNonce       :: Maybe Nonce
  , queryDescription :: Maybe Description
  , queryIdentity    :: Maybe Identity
  , queryMeta        :: Maybe Metadata
  } deriving (Generic, Show, Eq)

instance ToJSON Query where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Query

newtype Ok = Ok { msg :: String }
  deriving (Generic, Show)

instance ToJSON Ok where
  toEncoding = genericToEncoding defaultOptions

instance FromJSON Ok

-- | 'AppError' represents application errors
data AppError
  = Base64Decoding String
  | JsonDecoding String
  | Crypto CryptoError
  | AuthVerification String
  | Integrity String
  | FileSystem String
  | Default String
  deriving (Show, Eq)

-- | 'AppContext' represents the shared environment for computations which occur
-- within an 'AppM'
data AppContext = AppContext
  { _authFile :: FilePath
  , _conn     :: SQLite.Connection
  }

-- | 'AppM' is the application monad
newtype AppM a = AppM { unAppM :: ReaderT AppContext (ExceptT AppError IO) a }
  deriving ( Functor
           , Applicative
           , Monad
           , MonadError AppError
           , MonadIO
           , MonadReader AppContext
           )

runAppM :: AppContext -> AppM a -> IO (Either AppError a)
runAppM ctx = runExceptT . flip runReaderT ctx . unAppM

-- | 'Command' represents CLI commands
data Command
  = Add { addDescription :: String
        , addIdentity    :: Maybe String
        , addMeta        :: Maybe String
        }
  | Remove { removeDescription :: String }
  | Lookup { lookupDescription :: String }
  deriving Show

-- | 'Response' represents the response to a 'Command'
data Response
  = SingleEntry DisplayEntry
  | MultipleEntries [DisplayEntry]
  | SinglePlainText PlainText
  | Added
  | Removed
  deriving (Eq)

instance Show Response where
  show (SingleEntry e)      = show e
  show (MultipleEntries es) = show es
  show (SinglePlainText p)  = show p
  show Added                = "added"
  show Removed              = "removed"

{'fraction_non_alphanumeric': 0.0727206570329556, 'fraction_numerical': 0.006913400561388918, 'mean_word_length': 3.621426855632957, 'pattern_counts': {'":': 0, '<': 34, '<?xml version=': 0, '>': 54, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4583610', 'n_tokens_mistral': 5677, 'n_tokens_neox': 5463, 'n_words': 2114}