PersistenceSpec.hs

{-# LANGUAGE NamedFieldPuns #-}

module Festung.Vault.PersistenceSpec (spec) where

import Test.Hspec

import Control.Monad.Catch    (MonadMask)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Either
import Data.Word

import Festung.Vault.Persistence
import TestUtils


withVault :: (MonadIO m, MonadMask m) => (VaultHandle -> m a) -> m a
withVault action = withVaultName $ \ vaultName -> do
    vaultHandle <- liftIO $ unwrap <$> openVault vaultName password
    res <- action vaultHandle
    -- FIXME(Antoine): Should this be `finally`
    liftIO $ closeVault vaultHandle
    return res


withDataVault :: (MonadIO m, MonadMask m) => (VaultHandle -> m a) -> m a
withDataVault action = withVault $ \ vault -> do
    liftIO $ do createTable vault
                insertData vault
    action vault

password :: [Word8]
password = [0x66, 0x6f, 0x6f, 0x62, 0x61, 0x72]

otherPassword :: [Word8]
otherPassword = [0x66, 0x69, 0x67, 0x6f, 0x20, 0x47, 0x6d, 0x62, 0x48]

isNullQueryResult :: QueryResult -> Bool
isNullQueryResult QueryResult{rows} = null rows

createTable :: VaultHandle -> IO (Either Error QueryResult)
createTable = flip executeQuery $
    unlines [ "CREATE TABLE foo ("
            , "   bar  TEXT,"
            , "   baz  INT,"
            , "   qux  REAL,"
            , "   quux BLOB"
            , ");"
            ]

insertData :: VaultHandle -> IO (Either Error QueryResult)
insertData = flip executeQuery $
    unlines [ "INSERT INTO foo(bar, baz, qux, quux) VALUES"
            , "    ('a', 1, 1.5, x'DEADBEEF'),"
            , "    ('b', 2, 2.6, x'C0C4C01A'),"
            , "    ('c', 3, 3.7, x'DEADD00D')"
            ]

spec :: Spec
spec = do
    describe "openVault" $ do
        it "Creates the vault file if it does not exist" $ withVaultName $ \ vaultName -> do
            vault <- openVault vaultName password
            vault `shouldSatisfy` (not . isLeft)
            closeVault (unwrap vault)

        it "Returns an error if the password is incorrect" $ withVaultName $ \ vaultName -> do
            vault <- openVault vaultName password
            let vault' = unwrap vault
            -- SQLCipher only sets the password when data is written to the database,
            -- this includes CREATE TABLE and INSERTs
            createTable vault'
            closeVault vault'
            vault <- openVault vaultName otherPassword
            vault `shouldSatisfy` isLeft

    describe "executeQuery" $ do
        it "Returns an empty result when creating a table" $ withVault $ \ vault -> do
            result <- unwrap <$> executeQuery vault "CREATE TABLE foo(bar text)"
            result `shouldSatisfy` isNullQueryResult

        it "Returns an empty result when inserting data" $ withVault $ \ vault -> do
            createTable vault
            result <- unwrap <$> insertData vault
            result `shouldSatisfy` isNullQueryResult

        it "Can query data" $ withDataVault $ \ vault -> do
            QueryResult {rows} <- unwrap <$> executeQuery vault "SELECT bar FROM foo ORDER BY 1"
            rows `shouldBe` [ [StringValue "a"]
                            , [StringValue "b"]
                            , [StringValue "c"]
                            ]

        it "Returns headers for empty queries" $ withVault $ \ vault -> do
            createTable vault
            result <- unwrap <$> executeQuery vault "SELECT bar, baz, qux, quux FROM foo"
            rows result `shouldSatisfy` null
            headers result `shouldBe` [ ("bar" , Just "TEXT")
                                      , ("baz" , Just "INT" )
                                      , ("qux" , Just "REAL")
                                      , ("quux", Just "BLOB")
                                      ]


        it "Raises an error when multiple SQL statements are being run" pending

        it "Preserves types from the database" $ withDataVault $ \ vault -> do
            QueryResult {rows} <- unwrap <$> executeQuery vault
                "SELECT bar, baz, qux, quux FROM foo ORDER BY 1 LIMIT 1"
            rows `shouldBe` [[ StringValue "a"
                             , IntValue    1
                             , FloatValue  1.5
                             , BlobValue   [0xDE, 0xAD, 0xBE, 0xEF]
                             ]]

            result <- executeQuery vault $  "INSERT INTO foo(bar, baz, qux, quux) VALUES "
                                         ++ "    (NULL, NULL, NULL, NULL)"
            result `shouldSatisfy` isRight

    describe "executeParameterizedQuery" $ do
        it "Binds parameters to the query" $ withDataVault $ \ vault -> do
            QueryResult {rows} <- unwrap <$> executeParameterizedQuery vault
                "SELECT bar FROM foo WHERE bar = ? ORDER BY 1" [StringValue "a"]
            rows `shouldBe` [ [StringValue "a"] ]

        it "All times of parameters" $ withVault $ \ vault -> do
            createTable vault
            QueryResult {lastRowId} <- unwrap <$> executeParameterizedQuery vault
                "INSERT INTO foo(bar, baz, qux, quux) VALUES (?, ?, ?, ?)"
                [StringValue "hello", IntValue 1337, FloatValue 3.14, NullValue]
            lastRowId `shouldBe` 1

            -- FIXME(Antoine): Support blob
            result <- executeParameterizedQuery vault "SELECT ?" [BlobValue []]
            result `shouldSatisfy` isLeft

        it "Raises an error when the amount of parameters doesn't match" $ withDataVault $ \ vault -> do
            result <- executeParameterizedQuery vault
                "SELECT bar FROM foo WHERE bar IN (?, ?) ORDER BY 1" [StringValue "a"]
            result `shouldSatisfy` isLeft

        it "Binds the right type" $ withDataVault $ \ vault -> do
            executeQuery vault $  "INSERT INTO foo(bar, baz, qux, quux) VALUES "
                               ++ "    ('NULL', 0, 0.0, '')"
            executeQuery vault $  "INSERT INTO foo(bar, baz, qux, quux) VALUES "
                               ++ "    (NULL, NULL, NULL, NULL)"

            QueryResult {rows} <- unwrap <$> executeParameterizedQuery vault
                "SELECT count(*) as c FROM foo WHERE bar is ? or baz is ? or qux is ? or quux is ?"
                (replicate 4 NullValue)

            rows `shouldBe` [[IntValue 1]]