festung-0.9.1.1: tests/Festung/FrontendSpec.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
module Festung.FrontendSpec (spec) where
import Control.Monad
import Data.Aeson
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BS8
import Data.Int
import Data.List
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text as T
import qualified Data.Scientific as S
import Data.Semigroup ((<>))
import Data.Word
import qualified Network.Wai.Test as W
import System.Directory
import System.FilePath ((</>))
import System.IO (writeFile)
import Test.Hspec
import Test.HUnit (assertFailure)
import Yesod (liftIO, Yesod)
import Yesod.Test
import Festung.Config
import Festung.Frontend
import Festung.Utils (getVersion)
import Festung.Vault.VaultManager (newManager)
import qualified Festung.Vault.Persistence as P
import TestUtils
type VaultList = [String]
newtype SimpleQuery = SimpleQuery String
instance ToJSON SimpleQuery where
toJSON (SimpleQuery q) = object ["sql" .= q]
toEncoding (SimpleQuery q) = pairs ("sql" .= q)
data ResultValue = RString String
| RFloat Double
| RInt Int64
| RBlob [Word8]
| RNull
deriving (Eq, Show)
instance FromJSON ResultValue where
parseJSON (Number n) = return $ convert n
where convert = either RFloat RInt . S.floatingOrInteger
parseJSON (String s) = return $ convert s
where convert = RString . T.unpack
parseJSON Null = return RNull
parseJSON _ = fail "Could not parse the ResultValue"
instance ToJSON ResultValue where
toJSON (RString s) = String (T.pack s)
toJSON (RFloat f) = Number (S.fromFloatDigits f)
toJSON (RInt i) = Number (S.scientific (fromIntegral i) 0)
toJSON RNull = Null
type ResultRow = [ResultValue]
type HeaderType = String -- This should be an enum
type HeaderName = String
data Header = Header
{ headerType :: HeaderType
, headerName :: HeaderName
} deriving (Eq, Show)
instance FromJSON Header where
parseJSON = withObject "Expects an object" $ \r ->
Header <$>
r .: "type" <*>
r .: "name"
data Results = Results
{ rows :: [ResultRow]
, headers :: [Header]
, lastRowId :: Int
, rowsChanged :: Int
} deriving (Eq, Show)
instance FromJSON Results where
parseJSON = withObject "Results" $ \ r ->
Results <$>
r .: "data" <*>
r .: "headers" <*>
r .: "last_row_id" <*>
r .: "rows_changed"
data ErrorObject = ErrorObject { type_ :: T.Text, description :: T.Text }
instance FromJSON ErrorObject where
parseJSON = withObject "error root" $ \r -> do
err <- r .: "error"
ErrorObject <$> err .: "type" <*> err .: "description"
data ParametrizedQuery = ParametrizedQuery String [ResultValue]
instance ToJSON ParametrizedQuery where
toJSON (ParametrizedQuery sql params) = object [ "sql" .= sql
, "params" .= params
]
toEncoding (ParametrizedQuery sql params) = pairs ("sql" .= sql <> "params" .= params)
newtype Version = Version String deriving (Eq, Show)
instance FromJSON Version where
parseJSON = withObject "Version" $ \r ->
Version <$> r .: "version"
createCleanDirectory :: FilePath -> IO ()
createCleanDirectory dir = do
exists <- doesDirectoryExist dir
when exists $ removeDirectoryRecursive dir
createDirectory dir
withApp :: Int -> SpecWith (TestApp App) -> Spec
withApp timeout = before $ do
-- FIXME(Antoine): Hardcoded directory
-- This prevents tests to run in parallel...
let dir = "/tmp/test-festung"
createCleanDirectory dir
let config = Config dir timeout 0
vaultManager <- newManager config
return (App config vaultManager, id)
withApp_ :: SpecWith (TestApp App) -> Spec
withApp_ = withApp defaultTimeout
filterOut :: (a -> Bool) -> [a] -> [a]
filterOut p = filter (not . p)
listVaults :: YesodExample App VaultList
listVaults = do
dir <- vaultDirectory <$> getTestYesod
liftIO $ listDirectory dir
where listDirectory = fmap skipDotAndDotDot . getDirectoryContents
skipDotAndDotDot = filterOut isDotOrDotDot
isDotOrDotDot = (`elem` [".", ".."])
simpleBody :: W.SResponse -> B.ByteString
simpleBody = W.simpleBody
failure :: String -> YesodExample site a
failure msg = liftIO (assertFailure msg) >> fail "This should never run"
getJson :: FromJSON a => YesodExample site a
getJson = withResponse $ \ req ->
let body = simpleBody req
unwrap (Just a) = return a
unwrap Nothing = failure ("Invalid json: " ++ show body)
in unwrap $ decode body
encodePassword :: [Word8] -> BS.ByteString
encodePassword = B64.encode . BS.pack
encodeInteger :: Integer -> BS.ByteString
encodeInteger = encodeUtf8 . T.pack . show
postJson' :: (Yesod site, ToJSON a) => String -> [Word8] -> Maybe Integer -> a -> YesodExample site ()
postJson' url password kdfIter obj =
request $ do setUrl url
setMethod "POST"
setRequestBody (encode obj)
addRequestHeader ("Authorization", encodePassword password)
case kdfIter of
Just n -> addRequestHeader ("X-kdf-iter", encodeInteger n)
Nothing -> return ()
postJson :: (Yesod site, ToJSON a) => String -> [Word8] -> a -> YesodExample site ()
postJson url password = postJson' url password Nothing
deleteVault :: Yesod site => String -> [Word8] -> YesodExample site ()
deleteVault url password =
request $ do setUrl url
setMethod "DELETE"
addRequestHeader ("Authorization" ,encodePassword password)
password :: [Word8]
password = [0xDE, 0xAD, 0xBE, 0xEF]
otherPassword :: [Word8]
otherPassword = [0xD0, 0x00, 0x00, 0x0D]
createTable' :: (Yesod site) => String -> [Word8] -> Maybe Integer -> YesodExample site ()
createTable' vault password kdfIter = do
postJson' vault password kdfIter $ SimpleQuery "CREATE TABLE foo(bar int)"
statusIs 200
createTable :: (Yesod site) => String -> [Word8] -> YesodExample site ()
createTable vault password = createTable' vault password Nothing
createTableWithData :: (Yesod site) => String -> [Word8] -> YesodExample site ()
createTableWithData vault password = do
createTable vault password
postJson vault password $ SimpleQuery "INSERT INTO foo(bar) VALUES (1), (2)"
statusIs 200
res <- getJson
assertEq "data is returned" res
Results { rows = []
, headers = []
, lastRowId = 2
, rowsChanged = 2
}
hasVersionHeader :: (Yesod site) => YesodExample site ()
hasVersionHeader = assertHeader "X-Version" $ BS8.pack getVersion
spec :: Spec
spec = withApp_ $ do
describe "/" $ do
let get' = get ("/" :: String) >> statusIs 200
it "Lists the vaults" $ do
get'
res <- getJson
assertEq "No vault" res ([] :: [String])
directory <- vaultDirectory <$> getTestYesod
liftIO $ writeFile (directory </> "foo.sqlcipher") ""
get'
res <- getJson
assertEq "One foo vault" res (["foo"] :: [String])
hasVersionHeader
describe "GET /version" $
it "Returns the current version" $ do
get ("/version" :: String)
statusIs 200
res <- getJson
assertEq "Version info" res (Version getVersion)
hasVersionHeader
describe "Error object" $ do
it "Returns an error object on 404" $ do
get ("/inexistent/resounce/id" :: String)
statusIs 404
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
hasVersionHeader
it "Returns an error object on 403" $ do
createTable "/vault" password
postJson' "/vault" otherPassword Nothing $ SimpleQuery "SELECT * FROM foo"
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
statusIs 403
it "Returns an error object on 400" $ do
createTable "/vault" password
postJson' "/vault" password Nothing $ object []
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
statusIs 400
it "Returns an operational error" $ do
createTable "/vault" password
postJson' "/vault" password Nothing $ SimpleQuery "SELECT baz FROM foo"
ErrorObject{type_, description } <- getJson
assertEq "Type is 'operational_error" type_ "operational_error"
assertEq "Description mentions unkown column" description "no such column: baz"
statusIs 400
describe "POST /vault" $ do
it "Creates the vault" $ do
createTable "/vault" password
res <- getJson
assertEq "Empty results" res Results { rows = [], headers = [], lastRowId = 0 , rowsChanged = 0 }
vaults <- listVaults
assertEq "One vault" vaults ["vault.sqlcipher"]
hasVersionHeader
it "Checks the KDF iter for opened vaults" $ do
createTable' "/vault" password (Just 4000)
postJson' "/vault" password (Just 5000) $ SimpleQuery "SELECT 1"
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
statusIs 403
it "Opens the vault with the right KDF iter" $ do
directory <- vaultDirectory <$> getTestYesod
let vaultName = directory </> "foo.sqlcipher"
liftIO $ do
Right vault <- P.openVault' vaultName password P.VaultParameters { P.kdfIter = Just 5 }
_ <- P.executeQuery vault "CREATE TABLE foo (a int)"
P.closeVault vault
postJson' "/foo" password (Just 500) $ SimpleQuery "SELECT a FROM foo"
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
statusIs 403
it "Opens the vault with the right password" $ do
directory <- vaultDirectory <$> getTestYesod
let vaultName = directory </> "foo.sqlcipher"
liftIO $ do
Right vault <- P.openVault vaultName password
_ <- P.executeQuery vault "CREATE TABLE foo (a int)"
P.closeVault vault
postJson "/foo" otherPassword $ SimpleQuery "SELECT a FROM foo"
ErrorObject{type_} <- getJson
assertEq "Type is 'interface_error'" type_ "interface_error"
statusIs 403
it "Persists data" $ do
createTableWithData "/vault" password
postJson "/vault" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
statusIs 200
res <- getJson
assertEq "data is returned" res
Results { rows = [ [RInt 1]
, [RInt 2]
]
, headers = [Header "int" "bar"]
, lastRowId = 2
, rowsChanged = -1
}
it "Checks password" $ do
createTableWithData "/vault" password
postJson "/vault" otherPassword $ SimpleQuery "SELECT bar FROM foo"
statusIs 403
it "Binds parameters" $ do
createTableWithData "/vault" password
postJson "/vault" password $ ParametrizedQuery "INSERT INTO foo(bar) VALUES (?)" [RNull]
statusIs 200
postJson "/vault" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
res <- getJson
assertEq "data is returned" res
Results { rows = [ [RNull]
, [RInt 1]
, [RInt 2]
]
, headers = [Header "int" "bar"]
, lastRowId = 3
, rowsChanged = -1
}
it "Handles many vaults" $ do
createTableWithData "/a" password
createTableWithData "/b" otherPassword
createTableWithData "/c" password
vaults <- listVaults
assertEq "Three vaults" (sort vaults)
["a.sqlcipher", "b.sqlcipher", "c.sqlcipher"]
postJson "/a" otherPassword $ SimpleQuery "SELECT * FROM foo"
statusIs 403
postJson "/b" password $ SimpleQuery "SELECT * FROM foo"
statusIs 403
postJson "/a" password $ SimpleQuery "INSERT INTO foo(bar) VALUES (NULL)"
statusIs 200
postJson "/c" password $ SimpleQuery "SELECT bar FROM foo ORDER BY 1"
res <- getJson
assertEq "data is returned" res
Results { rows = [ [RInt 1]
, [RInt 2]
]
, headers = [Header "int" "bar"]
, lastRowId = 2
, rowsChanged = -1
}
describe "DELETE /vault" $ do
it "Deletes vaults" $ do
createTableWithData "/vault" password
deleteVault "/vault" password
statusIs 204
vaults <- listVaults
assertEq "One vault" vaults []
postJson "/vault" password $ SimpleQuery
"SELECT count(*) AS n_table FROM sqlite_master"
statusIs 200
res <- getJson
assertEq "data is returned" res
Results { rows = [[RInt 0]] -- 0 for no table
, headers = [Header "dynamic" "n_table"]
, lastRowId = 0
, rowsChanged = -1
}
it "Doesn't delete vaults with the wrong password" $ do
createTableWithData "/vault" password
deleteVault "/vault" otherPassword
statusIs 403