festung (empty) → 0.9.1.1
raw patch · 27 files changed
+2844/−0 lines, 27 filesdep +HUnitdep +aesondep +argparsersetup-changed
Dependencies added: HUnit, aeson, argparser, async, base, base64-bytestring, bytestring, case-insensitive, containers, directory, either, exceptions, festung, filepath, hspec, http-types, mtl, scientific, sqlcipher, temporary, text, transformers, unordered-containers, utf8-string, vector, wai, wai-extra, yesod, yesod-core, yesod-test
Files
- LICENSE +3/−0
- README.md +109/−0
- Setup.hs +2/−0
- festung.cabal +118/−0
- prog/Main.hs +42/−0
- src/Festung/Concurrency/Gig.hs +53/−0
- src/Festung/Concurrency/Job.hs +123/−0
- src/Festung/Concurrency/Utils.hs +66/−0
- src/Festung/Config.hs +7/−0
- src/Festung/Frontend.hs +209/−0
- src/Festung/Frontend/Converters.hs +83/−0
- src/Festung/Frontend/Validators.hs +48/−0
- src/Festung/Utils.hs +41/−0
- src/Festung/Vault.hs +14/−0
- src/Festung/Vault/Persistence.hs +488/−0
- src/Festung/Vault/VaultHandler.hs +114/−0
- src/Festung/Vault/VaultManager.hs +248/−0
- tests/Festung/Concurrency/GigSpec.hs +28/−0
- tests/Festung/Concurrency/JobSpec.hs +49/−0
- tests/Festung/Concurrency/UtilsSpec.hs +54/−0
- tests/Festung/Frontend/ConvertersSpec.hs +147/−0
- tests/Festung/FrontendSpec.hs +426/−0
- tests/Festung/Vault/PersistenceSpec.hs +151/−0
- tests/Festung/Vault/VaultHandlerSpec.hs +90/−0
- tests/Festung/Vault/VaultManagerSpec.hs +62/−0
- tests/Spec.hs +1/−0
- tests/TestUtils.hs +68/−0
+ LICENSE view
@@ -0,0 +1,3 @@+This project is not supposed to be public.++(C) All right are reserved by Figo GmbH.
+ README.md view
@@ -0,0 +1,109 @@+# Festung++Remote multi-db SQLCipher server exposing a REST API++++## Build++The `festung` container is built with the help of an auxiliary container called `steinmetz`.+The `steinmetz` container gathers and compiles all build dependencies, so that build process+of `festung` itself is faster. You can build both containers by invoking `make` with no+target.++```sh+$ make+```++## Run++To spin up a festung instance do++```sh+$ docker run --rm --tty --interactive --publish 127.0.0.1:2728:2728 --name festung festung+```++or just do++```sh+$ make start+```++If you want to persist the vaults between multiple runs, you either have to mount a directory+from the host system or create a docker volume. The latter could be done by doing++```sh+$ docker volume create vaults+```++and then run festung like so++```sh+$ docker run --rm -it -p 127.0.0.1:2728:2728 --mount source=vaults,target=/var/festung --name festung festung+```++## Interact++Once you have a festung instance running you can interact with the API by using `curl`, `httpie` or an+HTTP client of your choice.++The databases that are handled by festung are encrypted. The key is provided through the Authorization+header whose value is base64 encoded++```sh+$ echo foo | base64+Zm9vCg==+```++The request body for issuing queries against festung contains the fields `sql` and `params`. To create a+new table `foo` in the database `1` (encrypted with the password `"foo"`) you can issue the following +request:++```json+# http localhost:2728/1 Authorization:Zm9vCg== sql='CREATE TABLE foo (id INT, b VARCHAR)' params:='[]'+{+ "data": [],+ "headers": [],+ "last_row_id": 0,+ "rows_changed": 0+}+```++The `params` paramter can be used for parametrizing queries. Let's say we insterted some data in our+table++```json+# http localhost:2728/1 Authorization:Zm9vCg== sql='INSERT INTO foo VALUES (1, "b")' params:='[]'+{+ "data": [],+ "headers": [],+ "last_row_id": 0,+ "rows_changed": 0+}+```++then we could use `params` as follows:++```json+# http localhost:2728/1 Authorization:Zm9vCg== sql='SELECT * FROM foo WHERE id IN (?)' params:='[1]'+{+ "data": [+ [+ 1,+ "b"+ ]+ ],+ "headers": [+ {+ "name": "id",+ "type": "INT"+ },+ {+ "name": "b",+ "type": "VARCHAR"+ }+ ],+ "last_row_id": 0,+ "rows_changed": -1+}+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ festung.cabal view
@@ -0,0 +1,118 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: ebdc5912062cc97ec9e5e5a7344f76f21fe91f27244623a2e9d0c3915663018c++name: festung+version: 0.9.1.1+synopsis: Remote multi-db SQLCipher server+description: festung is a server that provides an HTTP API to execute queries+ against encrypted SQLite databases.+category: Concurrency+homepage: http://www.figo.io+author: Figo GmbH+maintainer: developer@figo.io+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ README.md++library+ exposed-modules:+ Festung.Concurrency.Job+ Festung.Concurrency.Gig+ Festung.Concurrency.Utils+ Festung.Config+ Festung.Frontend+ Festung.Frontend.Converters+ Festung.Frontend.Validators+ Festung.Utils+ Festung.Vault+ Festung.Vault.Persistence+ Festung.Vault.VaultHandler+ Festung.Vault.VaultManager+ other-modules:+ Paths_festung+ hs-source-dirs:+ src+ other-extensions: NamedFieldPuns OverloadedStrings QuasiQuotes TemplateHaskell TypeFamilies ViewPatterns+ ld-options: -pthread+ build-depends:+ aeson+ , argparser+ , async+ , base >=4.9 && <5.0+ , base64-bytestring+ , bytestring+ , case-insensitive+ , containers+ , directory+ , either <5+ , exceptions+ , filepath+ , http-types+ , mtl+ , scientific+ , sqlcipher+ , text+ , transformers+ , unordered-containers+ , utf8-string+ , vector+ , wai+ , yesod+ , yesod-core+ default-language: Haskell2010++executable festung+ main-is: Main.hs+ other-modules:+ Paths_festung+ hs-source-dirs:+ prog+ ghc-options: -threaded -rtsopts=all+ build-depends:+ argparser+ , base+ , festung+ , yesod+ default-language: Haskell2010++test-suite tests+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Festung.Concurrency.GigSpec+ Festung.Concurrency.JobSpec+ Festung.Concurrency.UtilsSpec+ Festung.Frontend.ConvertersSpec+ Festung.FrontendSpec+ Festung.Vault.PersistenceSpec+ Festung.Vault.VaultHandlerSpec+ Festung.Vault.VaultManagerSpec+ TestUtils+ Paths_festung+ hs-source-dirs:+ tests+ build-depends:+ HUnit+ , aeson+ , base+ , base64-bytestring+ , bytestring+ , containers+ , directory+ , exceptions+ , festung+ , filepath+ , hspec >=2.3 && <2.5+ , scientific+ , temporary+ , text+ , wai-extra+ , yesod+ , yesod-test+ default-language: Haskell2010
+ prog/Main.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE NamedFieldPuns #-}++module Main where++import Festung.Config+import Festung.Frontend (App(App))+import Festung.Utils (getVersion)+import Festung.Vault.VaultManager (newManager)+import System.Console.ArgParser+import Yesod (warp)+++-- FIXME: We pass config all over the place. It looks like this could be a+-- monad to maintain state.+applicationRunner :: Config -> IO ()+applicationRunner config@Config { port } = do+ vaultManager <- newManager config+ warp port (App config vaultManager)+++cmdLineInterface :: IO (CmdLnInterface Config)+cmdLineInterface =+ (`setAppDescr` "Remote SQLCipher server.") .+ (`setAppVersion` getVersion) <$>+ mkApp cmdLineParser+ where setAppVersion app v = app { getAppVersion = Just v }+++toMicroSeconds :: Int -> Int+toMicroSeconds = (*) (1000 * 1000)+++cmdLineParser :: ParserSpec Config+cmdLineParser = constructor+ `parsedBy` reqPos "data_directory" `Descr` "Location of the vaults"+ `andBy` optFlag 2728 "port" `Descr` "API port"+ `andBy` optFlag 15 "timeout" `Descr` "Vault timeout"+ where constructor dir port timeout = Config dir (toMicroSeconds timeout) port+++main :: IO ()+main = cmdLineInterface >>= flip runApp applicationRunner
+ src/Festung/Concurrency/Gig.hs view
@@ -0,0 +1,53 @@+module Festung.Concurrency.Gig + ( newGig+ , newGig_+ , Job+ , JobStatus+ ) where++import Control.Concurrent+import Control.Monad+import Festung.Concurrency.Job+import Festung.Concurrency.Utils (readChanTimeout, forkIOForSure)+++-- | Same as new job, but times out+--+-- Gigs are time limited jobs. Meaning that if no new action are+-- sent to a gig, the gig terminates. (or times out)+newGig :: Int -> a -> (a -> b -> IO (JobStatus, a)) -> IO (Job b)+newGig timeout init_ f = do+ chan <- newChan+ job <- newJob init_ $ \state cmd -> do+ writeChan chan cmd+ f state cmd+ timer <- newTimer timeout $ killJob job+ copier <- forkIOForSure $ forever (writeChan chan =<< readChan (snd timer))+ onExit job $ mapM_ killThread [fst timer, copier]+ return job+++-- | Create a gig without any state (just consuming the messages and possibly timing out)+newGig_ :: Int -> (b -> IO ()) -> IO (Job b)+newGig_ timeout f = newGig timeout () $ const (keepGoing f)+++-- | This is an internal function+--+-- This reads from the returned channel, and execute the action if no new value+-- is sent into its channel.+--+-- @+-- chan <- newTimer 1500 $ do+-- killJob foo+-- @+newTimer :: Int -> IO () -> IO (ThreadId, Chan a)+newTimer timeout action = do+ chan <- newChan+ thread <- forkIOForSure $ loop chan+ return (thread, chan)+ where loop chan = do + value <- readChanTimeout timeout chan+ case value of+ Just _ -> loop chan+ Nothing -> action
+ src/Festung/Concurrency/Job.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Concurrency.Job + ( Job+ , Command(..)+ , JobStatus(..)+ , newJob+ , newJob_+ , sendMappedCommand+ , sendCommand+ , killJob+ , keepGoing+ , isJobExited+ , isJobRunning+ , onExit+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Maybe++import Festung.Concurrency.Utils (readAnyMVar)+import Festung.Utils (eitherUnitToMaybe)+++data Job a = Job { chan :: Chan a+ , exited :: MVar ()+ , tid :: ThreadId+ }++instance Show (Job a) where+ show _ = "Job"++data Command c r = Command c (MVar r)+++data JobStatus = KeepGoing+ | Stop+++-- | Folds over all message sent to the job+--+-- Takes the initial state as the first argument.+-- The second argument is the folding function.+-- The last argument is the action to execute on exit.+newJob :: a -> (a -> b -> IO (JobStatus, a)) -> IO (Job b)+newJob init_ f = do+ chan <- newChan+ exited <- newEmptyMVar+ running <- newEmptyMVar+ tid <- forkIO $+ finally (putMVar running () >> consume chan init_)+ (putMVar exited ())+ readMVar running++ return Job { chan = chan, exited = exited, tid = tid }+ where consume chan ini = do+ msg <- readChan chan+ (status, state) <- mask_ $ f ini msg+ case status of+ KeepGoing -> consume chan state+ Stop -> return ()+++-- | Make a function always running+keepGoing :: (a -> IO b) -> (a -> IO (JobStatus, b))+keepGoing = (fmap . fmap) ((,) KeepGoing)+++-- | Create a job without any state (just consuming the messages)+newJob_ :: (b -> IO ()) -> IO (Job b)+newJob_ f = newJob () $ const (keepGoing f)+++-- | map the command before sending it to the job+--+-- Some job can receive multiple commands, therefore the use a+-- union type:+--+-- @+-- JobCommand = SquareCmd (Command Int Int)+-- | ConcatCmd (Command (String, String) String)+-- ...+-- @+--+-- This gives the ability to map the command with the constructor of the union type+-- before sending it to the job in question.+--+-- This sends the command in question, and waits for the result to be sent back.+--+-- If the job is exited, it returns @Nothing@+sendMappedCommand :: (Command c r -> a) -> Job a -> c -> IO (Maybe r)+sendMappedCommand constructor Job{chan,exited} command = do+ responder <- newEmptyMVar+ writeChan chan $ constructor (Command command responder)+ eitherUnitToMaybe <$> readAnyMVar exited responder++++-- | Same as @'sendMappedCommand', but for a job receiving only one command type.+sendCommand :: Job (Command c r) -> c -> IO (Maybe r)+sendCommand = sendMappedCommand id+++-- | Stops a running job, and wait for it to stop.+--+-- If the job is not running, this is a noop.+killJob :: Job a -> IO ()+killJob Job{tid,exited} = killThread tid >> readMVar exited+++isJobExited :: Job a -> IO Bool+isJobExited Job{exited} = isJust <$> tryReadMVar exited+++isJobRunning :: Job a -> IO Bool+isJobRunning job = not <$> isJobExited job+++-- | Register a finalizer when the job exits (even after an exception)+onExit :: Job a -> IO () -> IO ()+onExit Job{exited} action = void $ forkIO (readMVar exited >> action)
+ src/Festung/Concurrency/Utils.hs view
@@ -0,0 +1,66 @@+module Festung.Concurrency.Utils+ ( copyMVar+ , readAnyMVar+ , readMVarTimeout+ , readChanTimeout+ , forkIOForSure+ ) where++import Control.Concurrent+import Control.Monad+++-- | Copy (by using readMVar not takeMVar) an MVar into another MVar+copyMVar :: (a -> b) -> MVar a -> MVar b -> IO ()+copyMVar f src dst = putMVar dst =<< fmap f (readMVar src)+++-- | Read the first MVar that gets filled.+--+-- If both MVar get filled at the same time, or are already filled, the result of this+-- function is undefined.+readAnyMVar :: MVar a -> MVar b -> IO (Either a b)+readAnyMVar a b = do+ result <- newEmptyMVar+ first <- forkIO $ copyMVar Left a result+ second <- forkIO $ copyMVar Right b result++ takeMVar result+ <* mapM_ killThread [first, second]+++-- | Read the MVar with timeout+--+-- Try to read the MVar and return @'Nothing' if the MVar doesn't get filled+-- within a certain amount of microseconds.+readMVarTimeout :: Int -> MVar a -> IO (Maybe a)+readMVarTimeout timeout mvar = do+ timeoutMVar <- newEmptyMVar+ timeoutThread <- forkIO . void $ do threadDelay timeout+ tryPutMVar timeoutMVar ()+ result <- readAnyMVar timeoutMVar mvar+ killThread timeoutThread++ return $ case result of+ Left () -> Nothing+ Right e -> Just e+++-- | Read the next value from a @'Chan' within a certain time+--+-- Note: If this times out, nothing guarantee that the value hasn't been read+-- from the @'Chan' and discarded.+readChanTimeout :: Int -> Chan a -> IO (Maybe a)+readChanTimeout timeout chan = do+ mvar <- newEmptyMVar+ reader <- forkIO (putMVar mvar =<< readChan chan)+ readMVarTimeout timeout mvar+ <* killThread reader+++-- | Like forkIO but make sure the green thread is started+forkIOForSure :: IO () -> IO ThreadId+forkIOForSure action = do+ mvar <- newEmptyMVar+ forkIO (putMVar mvar () >> action)+ <* readMVar mvar
+ src/Festung/Config.hs view
@@ -0,0 +1,7 @@+module Festung.Config (Config(..)) where+++data Config = Config { dataDirectory :: String+ , vaultTimeout :: Int+ , port :: Int+ }
+ src/Festung/Frontend.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}++module Festung.Frontend+ ( App(..)+ , Widget+ , resourcesApp+ , vaultDirectory+ ) where++import Data.Aeson.Types as JT+import Data.Text (Text)+import qualified Data.Text as T+import Data.Word+import Festung.Config+import Festung.Frontend.Validators (validateVaultName)+import Festung.Frontend.Converters (queryParser, errorObj, resultEncoder)+import Festung.Utils (getVersion)+import qualified Festung.Vault.Persistence as P+import qualified Festung.Vault.VaultManager as VM+import qualified Festung.Vault.VaultHandler as VH+import qualified Festung.Vault as V+import System.Directory (getDirectoryContents)+import System.FilePath (dropExtension)+import Yesod+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as B64+import Data.CaseInsensitive (CI)+import Control.Monad+import Data.Text.Encoding (decodeUtf8)+import Network.HTTP.Types.Status+import Text.Read (readMaybe)+++data App = App+ { config :: Config+ , vaultManager :: VM.VaultManager+ }+++mkYesod "App" [parseRoutes|+ / HomeR GET+ /version VersionR GET+ !/#Text VaultR POST DELETE+|]+++addHeadersMiddleware :: Yesod site => [(Text, Text)] -> HandlerFor site res -> HandlerFor site res+addHeadersMiddleware headers handler = do+ forM_ headers $ uncurry addHeader+ handler+++getDefaultHeaders :: [(Text, Text)]+getDefaultHeaders = [ ("X-Version", T.pack getVersion) ]+++instance Yesod App where+ makeSessionBackend _ = return Nothing+ errorHandler NotFound =+ return $ toTypedContent $ errorObj "interface_error" "Invalid API endpoint."++ errorHandler (InvalidArgs args) =+ return $ toTypedContent $ errorObj "interface_error" message+ where message = T.unpack $ T.intercalate "\n" args++ errorHandler (PermissionDenied args) =+ return $ toTypedContent $ errorObj "interface_error" (T.unpack args)++ errorHandler err = defaultErrorHandler err -- REMOVEME+ yesodMiddleware = addHeadersMiddleware getDefaultHeaders . defaultYesodMiddleware+++vaultDirectory :: App -> FilePath+vaultDirectory = dataDirectory . config+++getVersionR :: Handler Value+getVersionR = return $ object [ "version" .= getVersion ]+++-- FIXME(Antoine): This should actually be querying the vault manager+getHomeR :: Handler Value+getHomeR = do+ directory <- vaultDirectory <$> getYesod+ content <- liftIO $ map dropExtension <$> listDirectory directory+ returnJson (content :: [String])+ where listDirectory directory = filter f <$> getDirectoryContents directory+ f name = V.isVault name && name `notElem` [".", ".."]+++withValidName :: MonadHandler m => (Text -> m a) -> Text -> m a+withValidName view vaultName =+ case validateVaultName vaultName of+ Just err -> invalidArgs [err]+ Nothing -> view vaultName++requireJsonBody' :: MonadHandler m => (Value -> JT.Parser a) -> m a+requireJsonBody' p = do+ res <- JT.parse p <$> requireJsonBody+ case res of+ JT.Error err -> invalidArgs [T.pack err]+ JT.Success val -> return val+++requireHeader :: MonadHandler m => CI BS.ByteString -> m BS.ByteString+requireHeader h = do+ res <- lookupHeader h+ case res of+ Just v -> return v+ Nothing -> invalidArgs [T.pack $ "Missing header " ++ show h]+++decodePassword :: BS.ByteString -> Either String [Word8]+decodePassword p = BS.unpack <$> B64.decode p+++requirePassword :: MonadHandler m => m [Word8]+requirePassword = do+ res <- decodePassword <$> requireHeader "Authorization"+ case res of+ Left err -> invalidArgs [T.pack $ "Base64 Error " ++ show err]+ Right password -> return password+++isWrongPassword :: Either VM.ManagerError a -> Bool+isWrongPassword (Left (VM.VaultError VH.CouldNotOpen)) = True+isWrongPassword _ = False+++parseInteger :: BS.ByteString -> Maybe Integer+parseInteger = readMaybe . T.unpack . decodeUtf8+++getKdfIter :: MonadHandler m => m (Maybe Integer)+getKdfIter = (>>= parseInteger) <$> lookupHeader "X-kdf-iter"+++withValidOpener :: MonadHandler m => (VH.VaultOpener -> m a) -> Text -> m a+withValidOpener view = withValidName $ \ name -> do+ -- FIXME(Antoine): This should be done somewhere else. Since Festung.Vault has this constant+ -- FIXME(Antoine): T.unpack... Ew...+ let name' = T.unpack name ++ ".sqlcipher"+ password <- requirePassword+ kdfIter <- getKdfIter+ let opener = (name', password, P.VaultParameters { P.kdfIter = kdfIter })+ view opener+++handleError :: VM.ManagerError -> Handler Value+handleError VM.CouldNotReachManager =+ sendStatusJSON serviceUnavailable503 $+ errorObj "internal_error" $+ concat [ "This is should never happen. The vault "+ , "manager very crashed..."+ ]+handleError (VM.VaultError VH.CouldNotOpen) =+ sendStatusJSON forbidden403 $+ -- FIXME(Antoine): This could also be: "the vault is corrupt"+ errorObj "interface_error" "Could not open the vault"+handleError (VM.VaultError VH.CouldNotReach) =+ sendStatusJSON serviceUnavailable503 $+ errorObj "internal_error" $+ concat [ "This error should almost never happen. "+ , "The vault was closed while trying to be accessed, "+ , "we tried to re-open it multiple times and failed."+ ]+handleError (VM.VaultError (VH.VaultError (P.InternalError d))) =+ sendStatusJSON badRequest400 $ errorObj "internal_error" d++handleError (VM.VaultError (VH.VaultError (P.NotSupportedError d))) =+ sendStatusJSON badRequest400 $ errorObj "not_supported" d++handleError (VM.VaultError (VH.VaultError (P.IntegrityError _ d))) =+ sendStatusJSON badRequest400 $ errorObj "integrity_error" d++handleError (VM.VaultError (VH.VaultError (P.OperationalError _ d))) =+ sendStatusJSON badRequest400 $ errorObj "operational_error" d++handleError (VM.VaultError (VH.VaultError (P.DatabaseError _ d))) =+ sendStatusJSON badRequest400 $ errorObj "database_error" d++handleError (VM.VaultError (VH.VaultError (P.DataError _ d))) =+ sendStatusJSON badRequest400 $ errorObj "data_error" d++handleError (VM.VaultError (VH.VaultError (P.ProgrammingError _ d))) =+ sendStatusJSON badRequest400 $ errorObj "programming_error" d+++postVaultR :: Text -> Handler Value+postVaultR = withValidOpener $ \opener -> do+ manager <- vaultManager <$> getYesod+ (sql, params) <- requireJsonBody' queryParser+ results <- liftIO $ VM.parametrizedQuery opener manager sql params+ when (isWrongPassword results) $ permissionDenied "Wrong password."+ case results of+ Left err -> handleError err+ Right res -> returnJson $ resultEncoder res++deleteVaultR :: Text -> Handler Value+deleteVaultR = withValidOpener $ \opener -> do+ manager <- vaultManager <$> getYesod+ results <- liftIO $ VM.deleteVault opener manager+ when (isWrongPassword results) $ permissionDenied "Wrong password."+ sendResponseStatus status204 ()
+ src/Festung/Frontend/Converters.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Frontend.Converters+ ( vaultObjectParser+ , parametersParser+ , queryParser+ , vaultObjectEncoder+ , rowEncoder+ , headerEncoder+ , resultEncoder+ , errorObj+ ) where++import Data.Aeson+import Data.Aeson.Types+import Data.Maybe+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Vector as V+import qualified Festung.Vault.Persistence as P+++-- | Backport of Data.Aeson.Encoding:array from aeson 1.0.0.0+array :: [Value] -> Value+array = Array . V.fromList+++-- | Converts a json object to a sqlcipher value+vaultObjectParser :: Value -> Parser P.Value+vaultObjectParser (String s) = return $ P.StringValue (T.unpack s)+vaultObjectParser (Number n) = return $ either P.FloatValue P.IntValue $ floatingOrInteger n+vaultObjectParser Null = return P.NullValue+vaultObjectParser _ = fail "Can't convert to a SQLCipher type"+++parametersParser :: Value -> Parser [P.Value]+parametersParser (Array a) = mapM vaultObjectParser (V.toList a)+parametersParser (Object _) = fail "Not implemented yet"+parametersParser _ = fail "Parameters must be an array, or a mapping of parameters"+++queryParser :: Value -> Parser (String, [P.Value])+queryParser = withObject "Should be a query object" $ \ obj -> do+ query <- obj .: "sql"+ paramsArray <- obj .:? "params" .!= emptyArray+ params <- parametersParser paramsArray+ return (query, params)+++vaultObjectEncoder :: P.Value -> Value+vaultObjectEncoder (P.IntValue i) = Number (scientific (fromIntegral i) 0)+vaultObjectEncoder (P.StringValue s) = String (T.pack s)+vaultObjectEncoder (P.FloatValue f) = Number (fromFloatDigits f)+vaultObjectEncoder P.NullValue = Null+++rowEncoder :: [P.Value] -> Value+rowEncoder = array . map vaultObjectEncoder+++headerEncoder :: [P.Header] -> Value+headerEncoder = array <$> map go+ where go (columnName, columnType) =+ let columnType' = fromMaybe "dynamic" columnType in+ object [ "name" .= String (T.pack columnName )+ , "type" .= String (T.pack columnType')+ ]+++resultEncoder :: P.QueryResult -> Value+resultEncoder P.QueryResult{P.rows, P.lastRowId, P.headers, P.rowsChanged} =+ let jsonHeaders = headerEncoder headers+ jsonRows = array $ map rowEncoder rows+ in object [ "headers" .= jsonHeaders+ , "data" .= jsonRows+ , "last_row_id" .= lastRowId+ , "rows_changed" .= fromMaybe (-1) rowsChanged+ ]+++errorObj :: String -> String -> Value+errorObj t d = object [ "error" .= object [ "type" .= t, "description" .= d ] ]
+ src/Festung/Frontend/Validators.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module Festung.Frontend.Validators+ ( validateVaultName+ ) where++import qualified Data.Text as Text+import Data.Char (isPrint, isAscii)+import Text.Printf (printf)+++type ErrorMessage = Text.Text+++validateVaultName :: Text.Text -> Maybe ErrorMessage+validateVaultName vaultName =+ -- XXX(Antoine): I'm not sure whether this should be read from the config+ -- or not. Anyhow, I want to avoid values that could reach the+ -- limits the file system (in this case the Maximum filename length)+ -- <https://en.wikipedia.org/wiki/Comparison_of_file_systems#Limits>+ -- This is only intented to support ext4, btrfs, zfs and ReiserFS.+ let maxVaultNameLength = 128+ hasChar c = Text.any (== c) vaultName+ maybeHead l =+ if null l then Nothing+ else Just (head l)++ -- We don't accept slashes and dots for obvious security reasons (we+ -- don't want people to be able to traverse directories.)+ hasSlash = hasChar '/'+ hasDot = hasChar '.'++ -- This might just be cargocult, we just don't want people to use weird+ -- characters for their vault names.+ isAllAscii = Text.all isAscii vaultName+ isAllPrintable = Text.all isPrint vaultName++ isTooLong = maxVaultNameLength < Text.length vaultName++ in+ -- XXX(Antoine): This is unreadable+ fmap (Text.pack . snd) $ maybeHead $ filter fst+ [ (hasSlash, "Vault names can't contain slashes")+ , (hasDot, "Vault names can't contain dots")+ , (not isAllAscii, "Vault names have to be ascii characters")+ , (not isAllPrintable, "Vault names have to have printable names")+ , (isTooLong, printf "We do not accept vault names longer than %d characters" maxVaultNameLength)+ ]
+ src/Festung/Utils.hs view
@@ -0,0 +1,41 @@+-- | These functions should be built-in haskell... But their not :(+--+-- The function type is the documentation for most of these functions++module Festung.Utils + ( eitherUnitToMaybe+ , hoistMEither+ , mapLeft+ , whenJust+ , getVersion+ ) where+++import Paths_festung (version)+import Data.Version (showVersion)+import Data.Either (either)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Either (hoistEither, EitherT)+import Control.Monad (join)+++getVersion :: String+getVersion = showVersion version+++eitherUnitToMaybe :: Either () a -> Maybe a+eitherUnitToMaybe = either (const Nothing) Just+++-- | Lift an @'Either' contain in a monad into an @'EitherT'+hoistMEither :: Monad m => m (Either e a) -> EitherT e m a+hoistMEither meither = join $ lift $ fmap hoistEither meither+++mapLeft :: (a -> c) -> Either a b -> Either c b+mapLeft f = either (Left . f) Right+++whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust (Just x) f = f x+whenJust Nothing _ = return ()
+ src/Festung/Vault.hs view
@@ -0,0 +1,14 @@+module Festung.Vault + ( extension+ , isVault+ ) where++import System.FilePath (takeExtension)+++extension :: String+extension = ".sqlcipher"+++isVault :: FilePath -> Bool+isVault filename = takeExtension filename == extension
+ src/Festung/Vault/Persistence.hs view
@@ -0,0 +1,488 @@+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Vault.Persistence+ ( openVault+ , openVault'+ , closeVault+ , Error(..)+ , VaultHandle+ , QueryResult(..)+ , executeQuery+ , executeParameterizedQuery+ , Value(..)+ , Header+ , ColumnName+ , ColumnType+ , Password+ , VaultParameters(..)+ ) where+++import qualified Codec.Binary.UTF8.String as UTF8+import Control.Exception.Base (assert)+import Control.Monad+import Control.Monad.Catch (finally)+import Control.Monad.Trans.Either (runEitherT, left, right, EitherT(..))+import Control.Monad.Error.Class (throwError, catchError, MonadError)+import Control.Monad.Trans (liftIO, lift)+import Data.Word+import Data.Either as E+import Foreign.C+import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Marshal.Array+import qualified Foreign.Concurrent as Conc+import Foreign.Storable+import Data.Functor ((<$>), void)+import Data.Int (Int64)+import Database.SQLCipher.Base+import Database.SQLCipher.Types+import Text.Printf (printf)++import Festung.Utils (hoistMEither, whenJust)+++{- This module basically interracts with raw C calls to SQLCipher. This+ - belongs in haskell-sqlcipher, however I (Antoine) wasn't sure what should go+ - there, and how the Haskell API should be structured.+ -+ - For this reason, I decided to put these C wrapping functions here, and see+ - where it goes. The plan is to upstream this in a near future™.+ -+ - A lot of these functions have been inspired by haskell-sqlcipher (which is based+ - on Database.SQLite)+ -}++newtype VaultHandle = VaultHandle (ForeignPtr ())++instance Show VaultHandle where+ show _ = "VaultHandle"++data Error = CouldNotOpenVault Status !String+ | MultipleStatements+ | WrongParametrization { got :: Int, expected :: Int }++ | NotSupportedError String+ | InternalError String+ | IntegrityError Status !String+ | OperationalError Status !String+ | DatabaseError Status !String+ | DataError Status !String+ | ProgrammingError Status !String+ deriving (Show)++data Value = StringValue String+ | IntValue Int64+ | FloatValue Double+ | BlobValue [Word8]+ | NullValue+ deriving (Show, Eq)++type Row = [Value]++-- FIXME(Antoine): Later on this should be an Enum. (Nothing should be "DYNAMIC")+type ColumnType = Maybe String+type ColumnName = String+type Header = (ColumnName, ColumnType)++data QueryResult = QueryResult+ { rows :: [Row]+ , lastRowId :: Int+ , rowsChanged :: Maybe Int+ , headers :: [Header]+ } deriving (Show)+++-- | Binary password to a vault (this password will be escaped)+type Password = [Word8]++newtype VaultParameters = VaultParameters { kdfIter :: Maybe Integer }+ deriving (Eq, Show)+++head' :: [a] -> Maybe a+head' [] = Nothing+head' (h:_) = Just h+++valueString :: Value -> String+valueString (StringValue s) = s+valueString (IntValue i) = show i+valueString (FloatValue f) = show f+valueString (BlobValue _) = undefined+valueString NullValue = "NULL"+++-- |@'encodeCString' encode a Haskell string for it to be used in C.+--+-- C functions only manipulates bytes because they use @char *@, this encodes+-- the string in UTF8, and returns a list of byte.+--+-- This utility function is only for internal use in Festung.Vault.Persistence.+encodeCString :: String -> [CChar]+encodeCString = map fromIntegral <$> UTF8.encode++-- |@'decodeCString' reverses @'encodeCString'+--+-- @decodeCString . encodeCString == id@+--+-- This utility function is only for internal use in Festung.Vault.Persistence.+decodeCString :: [CChar] -> String+decodeCString = UTF8.decode <$> map fromIntegral+++withUTF8CStringLen :: String -> (CStringLen -> IO a) -> IO a+withUTF8CStringLen str action =+ let cStr = encodeCString str+ in withArray0 0 cStr $ \ptr -> action (ptr, length cStr)+++-- |Convert a Haskell String to a @char *@ string, the time to execute an IO action.+withUTF8CString :: String -> (CString -> IO a) -> IO a+withUTF8CString str = + let cStr = encodeCString str+ in withArray0 0 cStr+++-- |peek @char *@ string into a Haskell String.+peekUTF8CString :: CString -> IO String+peekUTF8CString cStr = decodeCString <$> peekArray0 0 cStr+++-- |Get the error string from a errorneous status code+sqlCipherErrorString :: Status -> IO String+sqlCipherErrorString = peekCString . sqlite3_errstr+++sqlCipherErrorMessage :: SQLite -> IO String+sqlCipherErrorMessage db = peekUTF8CString =<< sqlite3_errmsg db+++-- |Get the @'Error' object for a status code+sqlCipherError :: Status -> (Status -> String -> Error) -> IO Error+sqlCipherError status constructor = constructor status <$> sqlCipherErrorString status+++sqlCipherErrorFromDb :: Status -> SQLite -> (Status -> String -> Error) -> IO Error+sqlCipherErrorFromDb status db constructor = constructor status <$> sqlCipherErrorMessage db+++toError :: Status -> SQLite -> IO Error+toError status db =+ let constructor = case status of+ _ | status `elem` + [ sQLITE_ERROR+ , sQLITE_PERM+ , sQLITE_ABORT+ , sQLITE_BUSY+ , sQLITE_LOCKED+ , sQLITE_READONLY+ , sQLITE_INTERRUPT+ , sQLITE_IOERR+ , sQLITE_FULL+ , sQLITE_CANTOPEN+ , sQLITE_PROTOCOL+ , sQLITE_EMPTY+ , sQLITE_SCHEMA+ ] -> OperationalError+ | status `elem` + [ sQLITE_CONSTRAINT+ , sQLITE_MISMATCH+ ] -> IntegrityError+ | status == sQLITE_CORRUPT -> DatabaseError+ | status == sQLITE_TOOBIG -> DataError+ | status == sQLITE_MISUSE -> ProgrammingError+ | otherwise -> DatabaseError+ in sqlCipherErrorFromDb status db constructor+++-- |Pass @[Word8]@ to a c function with the signature @int func(void *data, int dataLen)@+withData :: [Word8] -> (Int -> Ptr () -> IO a) -> IO a+withData data_ action =+ let cData = map fromIntegral data_ :: [CChar] + in withArrayLen cData $ \len dataPtr -> action len (castPtr dataPtr)+++-- |Read @void *data@+peekData :: Ptr () -> Int -> IO [Word8]+peekData ptr len =+ let ptr' = castPtr ptr :: Ptr CChar+ in map fromIntegral <$> peekArray len ptr'+++withPrim :: VaultHandle -> (SQLite -> IO a) -> IO a+withPrim (VaultHandle ptr) action = withForeignPtr ptr (action . SQLite)+++liftMEither :: Monad m => m (Either e a) -> EitherT e m a+liftMEither m = lift m >>= E.either left right+++-- |A computation to run, in case an error occurs.+--+-- This functions doesn't restore the state, it keeps the errored state.+onError :: (MonadError e m) => m () -> m a -> m a+onError errorAction action = catchError action $ \err -> errorAction >> throwError err+++-- |Just runs @sqlite3_open@.+--+-- This functions is for internal use only.+openSQLiteDB :: FilePath -> EitherT Error IO VaultHandle+openSQLiteDB filename =+ let newVaultHandle h@(SQLite ptr) = VaultHandle <$> Conc.newForeignPtr ptr sqlite3_close'+ where sqlite3_close' = void $ sqlite3_close h+ in liftMEither . alloca $ \dbPtr -> do+ status <- withUTF8CString filename $ flip sqlite3_open dbPtr+ if status == sQLITE_OK+ then Right <$> (newVaultHandle =<< peek dbPtr)+ else Left <$> sqlCipherError status OperationalError+++-- |@'usePassword' uses SQLCipher's @sqlite3_key@ special function to send the database password.+--+-- This utility function is only for internal use in Festung.Vault.Persistence,+-- more specificaly it should only be used in @'openVault'.+usePassword :: VaultHandle -> Password -> EitherT Error IO ()+usePassword handle password = liftMEither $ withPrim handle $ \db -> do+ status <- withData password $ \len passwordData ->+ let cLen = fromIntegral len + in sqlite3_key db passwordData cLen+ if status == sQLITE_OK+ then return $ Right ()+ else Left <$> toError status db+++-- |@'setKdfIter' run the @PRAGMA kdf_iter@+--+-- This utility function is for internal use only+setKdfIter :: VaultHandle -> Integer -> EitherT Error IO ()+setKdfIter handle kdfIter =+ let query = printf "PRAGMA kdf_iter = '%d'" kdfIter+ in void $ hoistMEither $ executeQuery handle query+++ensureIntegrity :: VaultHandle -> EitherT Error IO ()+ensureIntegrity handle = do+ result <- liftMEither $ executeQuery handle "PRAGMA quick_check(1)"+ let integrity_check = head . head . rows $ isIntegrityCheck result++ unless (isOk integrity_check) $ left $ IntegrityError sQLITE_MISMATCH (valueString integrity_check)+ where isOk (StringValue v) | v == "ok" = True+ | otherwise = False+ isIntegrityCheck r@QueryResult { headers } =+ assert (fmap fst (head' headers) == Just "integrity_check") r+++-- |@'openVault' opens the vault and returns an handle+openVault :: FilePath -> Password -> IO (Either Error VaultHandle)+openVault filename password = openVault' filename password noParams+ where noParams = VaultParameters { kdfIter = Nothing }+++openVault' :: FilePath -> Password -> VaultParameters -> IO (Either Error VaultHandle)+openVault' filename password VaultParameters{ kdfIter } = runEitherT $ do+ handle <- openSQLiteDB filename+ onError (liftIO $ closeVault handle) $ do+ usePassword handle password+ whenJust kdfIter $ setKdfIter handle+ ensureIntegrity handle+ return handle+++-- |@'withPreparedStatement' allocate a prepared statement+--+-- This function will finalize and dealocate the statement.+--+-- This helper function is inteded+withPreparedStatement :: SQLite -> String -> (SQLiteStmt -> IO a) -> IO (Either Error a)+withPreparedStatement db query action =+ alloca $ \ppStmt ->+ alloca $ \pzTail ->+ withArrayLen cData $ \nByte zSql -> do+ let nByte' = fromIntegral nByte+ status <- sqlite3_prepare db zSql nByte' ppStmt pzTail+ pStmt <- peek ppStmt+ runEitherT $ do+ -- FIXME(Antoine): Too many liftIO+ when (status /= sQLITE_OK) $+ left =<< liftIO (toError status db)++ when (isNullStmt pStmt) $+ left $ InternalError "Prepared statement was null."++ -- FIXME(Antoine): The double use of finalize is not great.+ let finalize = sqlite3_finalize pStmt++ -- TODO: Multiple statements+ -- when (pzTail /= nullPtr) (liftIO finalize >> left MultipleStatements)+ liftIO $ finally (action pStmt) finalize+ where cData = encodeCString query+++handleBindStatus :: Status -> SQLite -> EitherT Error IO ()+handleBindStatus status db =+ if status == sQLITE_OK+ then right ()+ else left =<< liftIO (toError status db)+++-- |@'bindParameter' binds one paramater to a statmeent.+--+-- This function is indented for internal use only.+bindParameter :: SQLite -> SQLiteStmt -> CInt -> Value -> EitherT Error IO ()+bindParameter db stmt idx (StringValue str) = do+ status <- liftIO $ withUTF8CStringLen str $ \(cStr, cStrLen) ->+ let cStrLen' = fromIntegral cStrLen+ in sqlite3_bind_text64 stmt idx cStr cStrLen' sqlite3_transient_destructor sQLITE_UTF8+ handleBindStatus status db++bindParameter db stmt idx (IntValue int) = do+ status <- liftIO $ sqlite3_bind_int64 stmt idx (fromIntegral int)+ handleBindStatus status db++bindParameter db stmt idx (FloatValue float) = do+ status <- liftIO $ sqlite3_bind_double stmt idx float+ handleBindStatus status db++bindParameter _db _stmt _idx (BlobValue _data) = left $ NotSupportedError "Binding blob is not supported yet."+bindParameter db stmt idx NullValue = do+ status <- liftIO $ sqlite3_bind_null stmt idx+ handleBindStatus status db+++fetchColumn :: SQLiteStmt -> Int -> EitherT Error IO Value+fetchColumn stmt pos = do+ let pos' = fromIntegral pos -- XXX(Antoine): This is copy pasted everywhere+ ct <- liftIO $ sqlite3_column_type stmt pos'+ case ct of+ _ | ct == sQLITE_INTEGER ->+ liftIO $ IntValue . fromIntegral <$> sqlite3_column_int64 stmt pos'+ | ct == sQLITE_FLOAT ->+ liftIO $ FloatValue <$> sqlite3_column_double stmt pos'+ | ct == sQLITE_NULL -> return NullValue+ | ct == sQLITE_TEXT -> liftIO $ do+ -- TODO: Use sqlite3_column_bytes AFTER+ -- TODO: Handle null pointer sqilte3_column_text+ cStr <- sqlite3_column_text stmt pos'+ StringValue <$> peekUTF8CString cStr+ | ct == sQLITE_BLOB -> liftIO $ do+ -- TODO: Handle null pointer+ blob <- sqlite3_column_blob stmt pos'+ blobLen <- sqlite3_column_bytes stmt pos'+ BlobValue <$> peekData blob (fromIntegral blobLen)+ | otherwise -> left $ ProgrammingError sQLITE_MISUSE $ "Unknown column type: " ++ show ct+++fetchColumnName :: SQLiteStmt -> Int -> EitherT Error IO ColumnName+fetchColumnName stmt pos = do+ let pos' = fromIntegral pos -- XXX(Antoine): This is copy pasted everywhere+ columnName <- liftIO $ sqlite3_column_name stmt pos'+ when (columnName == nullPtr) $ left $ InternalError "Couldn't fetch column name."+ liftIO $ peekUTF8CString columnName+++fetchColumnType :: SQLiteStmt -> Int -> EitherT Error IO ColumnType+fetchColumnType stmt pos = do+ let pos' = fromIntegral pos -- XXX(Antoine): This is copy pasted everywhere+ columnName <- liftIO $ sqlite3_column_decltype stmt pos'+ if columnName == nullPtr+ then return Nothing+ else liftIO $ Just <$> peekUTF8CString columnName+++fetchColumnHeader :: SQLiteStmt -> Int -> EitherT Error IO Header+fetchColumnHeader stmt pos =+ pure (,) <*>+ fetchColumnName stmt pos <*>+ fetchColumnType stmt pos+++mapColumns :: (SQLiteStmt -> Int -> EitherT Error IO a) -> SQLiteStmt -> EitherT Error IO [a]+mapColumns f stmt = do+ nCol <- liftIO $ fromIntegral <$> sqlite3_column_count stmt+ mapM (f stmt) $ take nCol [0..]+++fetchRow :: SQLiteStmt -> EitherT Error IO Row+fetchRow = mapColumns fetchColumn+++fetchHeaders :: SQLiteStmt -> EitherT Error IO [Header]+fetchHeaders = mapColumns fetchColumnHeader+++fetchResults :: SQLite -> SQLiteStmt -> EitherT Error IO [Row]+fetchResults db stmt =+ let go acc = do+ status <- liftIO $ sqlite3_step stmt+ case status of+ _ | status == sQLITE_DONE -> return $ reverse acc+ | status == sQLITE_ROW -> do+ row <- fetchRow stmt+ go (row:acc)+ | otherwise -> left =<< liftIO (toError status db)+ in go []+++bindManyParameters :: SQLite -> SQLiteStmt -> [Value] -> EitherT Error IO ()+bindManyParameters db stmt params = do+ expects <- liftIO $ fromIntegral <$> sqlite3_bind_parameter_count stmt++ let got = length params+ unless (expects == got) $ left $ ProgrammingError sQLITE_MISUSE (+ "Wrong param count. Got: " ++ show got ++ " Expected: " ++ show expects)++ let indices = take (length params) [1..]+ binders = map (bindParameter db stmt) indices++ zipWithM_ ($) binders params+++executeQuery :: VaultHandle -> String -> IO (Either Error QueryResult)+{-# INLINE executeQuery #-}+executeQuery handle query = executeParameterizedQuery handle query []+++stmtReadOnly :: SQLiteStmt -> IO Bool+stmtReadOnly stmt = (/= 0) <$> sqlite3_stmt_readonly stmt+++rowsAffected :: SQLite -> SQLiteStmt -> IO (Maybe Int)+rowsAffected db stmt = do+ readOnly <- stmtReadOnly stmt+ if not readOnly+ then Just . fromIntegral <$> sqlite3_changes db+ else return Nothing+++-- |@'fetchResults' fetch all results from a prepared+++-- |@'executeParameterizedQuery' executes a SQL query, with *un-named* parameters.+--+-- @executeParameterizedQuery "SELECT * FROM table WHERE value = ?" [NullValue]+--+executeParameterizedQuery :: VaultHandle -> String -> [Value] -> IO (Either Error QueryResult)+executeParameterizedQuery handle query params = withPrim handle $ \db ->+ fmap join <$> withPreparedStatement db query $ \pStmt -> runEitherT $ do+ bindManyParameters db pStmt params+ rows <- fetchResults db pStmt+ headers <- fetchHeaders pStmt+ rowsChanged <- liftIO $ rowsAffected db pStmt+ lastRowId <- liftIO $ lastInsertRowId db+ return QueryResult { rows = rows+ , headers = headers+ , lastRowId = lastRowId+ , rowsChanged = rowsChanged+ }+++lastInsertRowId :: SQLite -> IO Int+lastInsertRowId = fmap fromIntegral . sqlite3_last_insert_rowid+++-- |@'closeVault' closes a vault handle+closeVault :: VaultHandle -> IO ()+closeVault (VaultHandle ptr) = finalizeForeignPtr ptr
+ src/Festung/Vault/VaultHandler.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Vault.VaultHandler + ( VaultOpener+ , Vault+ , VaultError(..)+ , newHandler+ , query+ , parametrizedQuery+ , checkOpener+ , updateOpenerPath+ ) where++import Control.Monad.Trans.Either+import Control.Monad.Trans.Class+import Control.Concurrent+import System.Directory (canonicalizePath)+import System.FilePath ((</>))++import Festung.Config (Config(..))+import Festung.Utils (hoistMEither, mapLeft)+import qualified Festung.Vault.Persistence as P+import Festung.Concurrency.Job+import Festung.Concurrency.Gig+++-- | Data necessary to open vault (filename, password, parameters)+type VaultOpener = (FilePath, P.Password, P.VaultParameters)++data VaultError = CouldNotReach+ | CouldNotOpen+ | VaultError P.Error + deriving (Show)++data VaultCommand = Query (Command String (Either VaultError P.QueryResult))+ | ParametrizedQuery (Command (String, [P.Value]) (Either VaultError P.QueryResult))++type Vault = Job (VaultOpener, VaultCommand)+++type VaultState = (VaultOpener, P.VaultHandle)+++-- | Create a new vault handler job+newHandler :: Config -> VaultOpener -> IO (Either VaultError Vault)+newHandler config@Config{dataDirectory,vaultTimeout} opener@(path, password, params) = runEitherT $ do+ canonicalPath <- lift $ canonicalizePath $ dataDirectory </> path+ handle <- hoistMEither $ mapLeft (const CouldNotOpen) <$> P.openVault' canonicalPath password params+ lift $ do+ let state = (opener, handle)+ vault <- newGig vaultTimeout state $ handlerLoop config+ onExit vault (P.closeVault handle)+ return vault+++checkOpener :: VaultOpener -> VaultOpener -> IO (Either VaultError ())+checkOpener o1 o2 =+ return $ if o1 == o2 + then Right ()+ else Left CouldNotOpen+++updateOpenerPath :: VaultOpener -> FilePath -> VaultOpener+updateOpenerPath (_, password, params) path = (path, password, params)+++-- | Vault handler consuming messages send to the processor+--+-- This function is for internal use only+handlerLoop :: Config -> VaultState -> (VaultOpener, VaultCommand) -> IO (JobStatus, VaultState)+handlerLoop _config state@(opener, vault) (cmdOpener, cmd) = do+ err <- checkOpener opener cmdOpener+ case err of+ Left msg -> handleError cmd msg+ Right _ -> handleCommand vault cmd+ return (KeepGoing, state)+++wrapVaultErrors :: Either P.Error a -> Either VaultError a+wrapVaultErrors = mapLeft VaultError+++-- FIXME(Antoine): This code is totally copy pasted, we need to find a better+-- solution for this+handleCommand :: P.VaultHandle -> VaultCommand -> IO ()+handleCommand vault (Query (Command query_ responder)) =+ putMVar responder =<< wrapVaultErrors <$> P.executeQuery vault query_+handleCommand vault (ParametrizedQuery (Command (query_, params) responder)) =+ putMVar responder =<< wrapVaultErrors <$> P.executeParameterizedQuery vault query_ params+++-- FIXME(Antoine): This code is totally copy pasted, we need to find a better+-- solution for this. Type kinds, or polymorphism, I don't want+-- to use dynamic types.+handleError :: VaultCommand -> VaultError -> IO ()+handleError (Query (Command _ responder)) err = putMVar responder (Left err)+handleError (ParametrizedQuery (Command _ responder)) err = putMVar responder (Left err)+++flattenError :: Maybe (Either VaultError a) -> Either VaultError a+flattenError Nothing = Left CouldNotReach+flattenError (Just e) = e+++-- | Execute a query+query :: VaultOpener -> Vault -> String -> IO (Either VaultError P.QueryResult)+query o v q = flattenError <$> sendMappedCommand f v q+ where f = (,) o . Query+++-- | Execute a parametrized query+parametrizedQuery :: VaultOpener -> Vault -> String -> [P.Value] -> IO (Either VaultError P.QueryResult)+parametrizedQuery o v q p = flattenError <$> sendMappedCommand f v (q, p)+ where f = (,) o . ParametrizedQuery
+ src/Festung/Vault/VaultManager.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Vault.VaultManager + ( newManager+ , stopManager+ , VaultManager+ , query+ , parametrizedQuery+ , deleteVault+ , ManagerError(..)+ ) where++import Control.Concurrent+import Control.Monad+import qualified Data.HashMap.Strict as M+import Data.Either (isRight)+import Control.Monad.Trans.Either+import System.FilePath ((</>), normalise)+import System.Directory++import Festung.Concurrency.Job+import Festung.Concurrency.Utils+import Festung.Config+import qualified Festung.Vault.VaultHandler as V+import qualified Festung.Vault.Persistence as P+import Festung.Utils (hoistMEither, mapLeft, whenJust)+++type VaultManager = Job VaultManagerCommand++data ManagerError = VaultError V.VaultError+ | CouldNotReachManager+ deriving (Show)++type TimeoutSubscriber = MVar ()++data VaultManagerCommand = OpenVault (Command V.VaultOpener (Either ManagerError V.Vault))+ | VaultTimedOut (Command V.VaultOpener (Either ManagerError ()))+ | GetSubscription (Command V.VaultOpener (Either ManagerError TimeoutSubscriber))+ | DeleteVault (Command V.VaultOpener (Either ManagerError ()))+++type VaultMapKey = FilePath++data VaultMapValue = VaultMapValue { opener :: V.VaultOpener+ , vault :: V.Vault+ , subscriptions :: [TimeoutSubscriber]+ }++type VaultMap = M.HashMap VaultMapKey VaultMapValue++data ManagerState = ManagerState { registry :: VaultMap+ , timeouts :: Chan V.VaultOpener+ }+++-- | Initial manager state (for internal use only)+newInitialState :: IO ManagerState+newInitialState = do+ timeouts <- newChan+ return ManagerState { registry = M.empty, timeouts = timeouts }+++addSubscription :: TimeoutSubscriber -> VaultMapValue -> VaultMapValue+addSubscription s val@VaultMapValue{subscriptions} =+ let subscriptions' = s:subscriptions in+ val{subscriptions=subscriptions'}+++-- | Create a timeout consumer+--+-- Process that reads a @'Chan' of vault opener and sends a VaultTimoedOut command+-- to the manager whan a new value is sent to the @'Chan' in question.+--+-- This is for internal use only+newTimeoutConsumer :: VaultManager -> Chan V.VaultOpener -> IO ThreadId+newTimeoutConsumer manager timeouts =+ let sendTimeout = sendMappedCommand VaultTimedOut in+ forkIOForSure $ forever $ do + opener <- readChan timeouts+ sendTimeout manager opener+++newManager :: Config -> IO VaultManager+newManager config = do+ state <- newInitialState+ manager <- newJob state $ handlerLoop config+ timeoutConsumer <- newTimeoutConsumer manager (timeouts state)+ onExit manager $ killThread timeoutConsumer+ return manager+++stopManager :: VaultManager -> IO ()+stopManager = killJob+++updateStateRegistry :: (VaultMap -> VaultMap) -> ManagerState -> ManagerState+updateStateRegistry f ManagerState{registry,timeouts} =+ ManagerState { registry = f registry, timeouts = timeouts }+++-- | Internal function to check the opener when+canAccess :: VaultMap -> VaultMapKey -> V.VaultOpener -> IO Bool+canAccess mapping key opener =+ case M.lookup key mapping of+ Just VaultMapValue{opener=opener'} -> isRight <$> V.checkOpener opener opener'+ Nothing -> return True+++-- | Manager intenal loop (for internal use only)+handlerLoop :: Config -> ManagerState -> VaultManagerCommand -> IO (JobStatus, ManagerState)+handlerLoop config state cmd = do+ let opener@(path, _, _) = getOpener cmd+ key = normalise path+ canAccess' <- canAccess (registry state) key opener+ state' <- if canAccess'+ -- The opener is wrong, we stupidly say "vault does not exist" because you can't+ -- access this vault with these parameters.+ then handleCommand config state key cmd+ else handleError cmd (VaultError V.CouldNotOpen) >> return state+ return (KeepGoing, state')+++-- FIXME(Antoine): This code is totally copy pasted. This needs to use polymorphism.+handleError :: VaultManagerCommand -> ManagerError -> IO ()+handleError (OpenVault (Command _ responder)) err = putMVar responder (Left err)+handleError (VaultTimedOut (Command _ responder)) err = putMVar responder (Left err)+handleError (DeleteVault (Command _ responder)) err = putMVar responder (Left err)+++getOpener :: VaultManagerCommand -> V.VaultOpener+getOpener (OpenVault (Command o _)) = o+getOpener (VaultTimedOut (Command o _)) = o+getOpener (DeleteVault (Command o _)) = o+getOpener (GetSubscription (Command o _)) = o+++-- XXX(Antoine): This is very very bad code+handleCommand :: Config -> ManagerState -> VaultMapKey -> VaultManagerCommand -> IO ManagerState+handleCommand config state key (OpenVault (Command opener responder)) =+ case M.lookup key (registry state) of+ Just VaultMapValue{vault} -> do+ putMVar responder (Right vault)+ return state+ Nothing -> do+ res <- wrapManagerError <$> V.newHandler config opener+ -- FIXME(Antoine): Nesting!!!+ case res of+ Left err -> do+ putMVar responder (Left err)+ return state+ Right vault -> do+ onExit vault $ writeChan (timeouts state) opener+ putMVar responder (Right vault)+ let value = VaultMapValue {opener=opener, vault=vault, subscriptions=[]}+ return $ updateStateRegistry (M.insert key value) state++handleCommand _config state key (VaultTimedOut (Command _opener responder)) = do+ whenJust (M.lookup key (registry state)) $ \ VaultMapValue{vault,subscriptions} -> do+ killJob vault -- Just making sure the vault is dead+ forM_ subscriptions $ \ s ->+ void $ tryPutMVar s ()+ putMVar responder $ Right ()+ return $ updateStateRegistry (M.delete key) state++handleCommand _config state key (GetSubscription (Command _opener responder)) =+ let noop = do subscription <- newMVar ()+ putMVar responder $ Right subscription+ return state+ in+ case M.lookup key (registry state) of+ Just VaultMapValue{vault} -> do+ running <- isJobRunning vault+ if running+ then noop+ else do+ subscription <- newEmptyMVar+ let addSubscription' = addSubscription subscription+ putMVar responder $ Right subscription+ return $ updateStateRegistry (M.adjust addSubscription' key) state+ Nothing -> noop++handleCommand Config{dataDirectory} state key (DeleteVault (Command _opener responder)) = do+ let deleteVault = do filename <- canonicalizePath $ dataDirectory </> key+ exists <- doesFileExist filename+ when exists $ removeFile filename+ case M.lookup key (registry state) of+ Just VaultMapValue{vault, subscriptions} -> do+ killJob vault+ forM_ subscriptions $ \s -> void $ tryPutMVar s ()+ deleteVault+ Nothing -> deleteVault+ putMVar responder $ Right ()+ return $ updateStateRegistry (M.delete key) state+++wrapManagerError :: Either V.VaultError a -> Either ManagerError a+wrapManagerError = mapLeft VaultError+++flattenError :: Maybe (Either ManagerError a) -> Either ManagerError a+flattenError Nothing = Left CouldNotReachManager+flattenError (Just e) = e+++-- | This is for internal use only+getVault :: V.VaultOpener -> VaultManager -> EitherT ManagerError IO V.Vault+getVault opener manager = hoistMEither $ flattenError <$> sendMappedCommand OpenVault manager opener+++-- | This is for internal use only+waitForTimeout :: V.VaultOpener -> VaultManager -> IO (Either ManagerError ())+waitForTimeout opener manager =+ waitOnSubscription =<< flattenError <$> sendMappedCommand GetSubscription manager opener+ where waitOnSubscription (Left err) = return $ Left err+ waitOnSubscription (Right mvar) = readMVar mvar >> return (Right ())+++retryWhenTimedOut :: V.VaultOpener -> VaultManager -> IO (Either ManagerError a)+ -> IO (Either ManagerError a)+retryWhenTimedOut opener manager action = do+ res <- action+ case res of+ Left (VaultError V.CouldNotReach) -> do+ timeout <- waitForTimeout opener manager+ case timeout of+ Left err -> return $ Left err+ Right _ -> action+ _ -> return res+++-- | Execute a query on a vault+query :: V.VaultOpener -> VaultManager -> String -> IO (Either ManagerError P.QueryResult)+query opener manager query_ = retryWhenTimedOut opener manager $ runEitherT $ do+ vault <- getVault opener manager+ hoistMEither $ wrapManagerError <$> V.query opener vault query_+++-- | Execute a parametrized query+parametrizedQuery :: V.VaultOpener -> VaultManager -> String -> [P.Value]+ -> IO (Either ManagerError P.QueryResult)+parametrizedQuery opener manager query_ params = retryWhenTimedOut opener manager $ runEitherT $ do+ vault <- getVault opener manager+ hoistMEither $ wrapManagerError <$> V.parametrizedQuery opener vault query_ params+++deleteVault :: V.VaultOpener -> VaultManager -> IO (Either ManagerError ())+deleteVault opener manager = flattenError <$> sendMappedCommand DeleteVault manager opener
+ tests/Festung/Concurrency/GigSpec.hs view
@@ -0,0 +1,28 @@+module Festung.Concurrency.GigSpec (spec) where++import Test.Hspec++import Control.Concurrent+import Festung.Concurrency.Job+import Festung.Concurrency.Gig+++newSquareGig :: Int -> IO (Job (Command Int Int))+newSquareGig timeout = newGig_ timeout handler+ where handler (Command n responder) = putMVar responder (n * n)+++noTimeout :: Int+noTimeout = 2 * 60 * 1000 * 1000 -- Two minutes is a long timeout+++spec :: Spec+spec =+ describe "newGig" $ do+ it "Starts a new gig" $ do+ job <- newSquareGig noTimeout+ isJobRunning job `shouldReturn` True++ it "Processes messages" $ do+ job <- newSquareGig noTimeout+ sendCommand job 2 `shouldReturn` Just 4
+ tests/Festung/Concurrency/JobSpec.hs view
@@ -0,0 +1,49 @@+module Festung.Concurrency.JobSpec (spec) where++import Test.Hspec++import Control.Concurrent+import Data.Maybe (isNothing)+import Festung.Concurrency.Job+++newSquareJob :: IO (Job (Command Int Int))+newSquareJob = newJob_ handler+ where handler (Command n responder) = putMVar responder (n * n)+++-- Same as isEmptyMVar except that it really tries to read the MVar.+checkEmptyMVar :: MVar a -> IO Bool+checkEmptyMVar mvar = isNothing <$> tryReadMVar mvar+++spec :: Spec+spec = do+ describe "newJob" $+ it "Starts a running job" $ do+ job <- newSquareJob+ isJobRunning job `shouldReturn` True++ describe "sendCommand" $ do+ it "Sends commands" $ do+ job <- newSquareJob+ let sendCommand' = sendCommand job+ sendCommand' 1 `shouldReturn` Just 1+ sendCommand' 2 `shouldReturn` Just 4++ it "Returns Nothing when the Job is terminated" $ do+ job <- newSquareJob+ killJob job+ sendCommand job 1 `shouldReturn` Nothing++ -- These tests might be flaky. Remove them if they fail!+ describe "killJob" $ do+ it "Exits the job" $ do+ job <- newSquareJob+ killJob job+ isJobExited job `shouldReturn` True++ it "Prevents the job from running" $ do+ job <- newSquareJob+ killJob job+ isJobRunning job `shouldReturn` False
+ tests/Festung/Concurrency/UtilsSpec.hs view
@@ -0,0 +1,54 @@+module Festung.Concurrency.UtilsSpec (spec) where++import Test.Hspec++import Control.Concurrent+import Control.Applicative+import Festung.Concurrency.Utils+++oneSecond :: Int+oneSecond = 1 * 1000 * 1000+++spec :: Spec+spec = do+ describe "copyMVar" $ do+ it "Copies content without taking it" $ do+ src <- newMVar ()+ dst <- newEmptyMVar+ copyMVar id src dst+ tryReadMVar src `shouldReturn` Just ()+ tryReadMVar dst `shouldReturn` Just ()++ describe "readAnyMVar" $ do+ let getMVars = pure (,) <*> newMVar 1 <*> (newEmptyMVar :: IO (MVar ()))++ it "Reads non-empty mvar" $ do+ (value, empty) <- getMVars+ readAnyMVar value empty `shouldReturn` Left 1+ readAnyMVar empty value `shouldReturn` Right 1++ it "Doesn't take the non-empty mvar" $ do+ (value, empty) <- getMVars+ readAnyMVar value empty `shouldReturn` Left 1+ tryReadMVar value `shouldReturn` Just 1++ describe "readMVarTimeout" $ do+ it "Reads a filled mvar" $ do+ filled <- newMVar ()+ readMVarTimeout oneSecond filled `shouldReturn` Just ()++ it "Times out" $ do+ empty <- newEmptyMVar :: IO (MVar ())+ readMVarTimeout 0 empty `shouldReturn` Nothing++ describe "readChanTimeout" $ do+ it "Reads a Chan with data" $ do+ chan <- newChan+ writeChan chan ()+ readChanTimeout oneSecond chan `shouldReturn` Just ()++ it "Times out" $ do+ chan <- newChan :: IO (Chan ())+ readChanTimeout 0 chan `shouldReturn` Nothing
+ tests/Festung/Frontend/ConvertersSpec.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE OverloadedStrings #-}++module Festung.Frontend.ConvertersSpec (spec) where+++import Test.Hspec++import Festung.Frontend.Converters+import qualified Festung.Vault.Persistence as P+import Data.Aeson.Types+import Data.Aeson+import Data.Either+import qualified Data.ByteString.Lazy as BS+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text as T+import Data.ByteString.Builder (toLazyByteString)+++convert :: (Value -> Parser a) -> BS.ByteString -> Either String a+convert p content = parseEither p =<< eitherDecode content+++serialize :: (a -> Value) -> a -> BS.ByteString+serialize e = encode . e++integerToByteString :: Integer -> BS.ByteString+integerToByteString = BS.fromStrict . encodeUtf8 . T.pack . show++unlines' :: [BS.ByteString] -> BS.ByteString+unlines' = BS.intercalate "\n"+++pendingCustomDecimal :: IO ()+pendingCustomDecimal =+ pendingWith "This doesn't work without a custom Value which handles decimal/non-decimal"+++spec :: Spec+spec = do+ describe "vaultObjectParser" $ do+ let convert' = convert vaultObjectParser++ it "Parses integer" $ do+ convert' "1234" `shouldBe` Right (P.IntValue 1234)+ convert' "0" `shouldBe` Right (P.IntValue 0)++ it "Validates integers over 64bits" $ do+ pendingWith "Not important right now. But needs to be implemented some day™"+ let bigInteger = (2 ^ 64 + 1) :: Integer+ convert' (integerToByteString bigInteger) `shouldSatisfy` isLeft++ it "Parses floats" $ do+ convert' "3.14" `shouldBe` Right (P.FloatValue 3.14)+ convert' "1E-1" `shouldBe` Right (P.FloatValue 0.1)++ it "Parses float without decimals" $ do+ pendingCustomDecimal+ convert' "1.0" `shouldBe` Right (P.FloatValue 1.0)+ convert' "2.0e5" `shouldBe` Right (P.FloatValue 200000)++ it "Parses strings" $+ convert' "\"Hello\"" `shouldBe` Right (P.StringValue "Hello")++ it "Parses unicode (in this case the snowman character)" $+ convert' "\"\\u2603\"" `shouldBe` Right (P.StringValue "☃")++ it "Parses NULL values" $+ convert' "null" `shouldBe` Right P.NullValue++ it "Prevents bad data" $ do+ convert' "{}" `shouldSatisfy` isLeft+ convert' "[]" `shouldSatisfy` isLeft+ convert' "{\"foo\": \"bar\"}" `shouldSatisfy` isLeft+ convert' "[1, 2, 3.5]" `shouldSatisfy` isLeft++ it "Parses blobs" $ do+ pending+ let expected = P.BlobValue [0xDE, 0xAD, 0xBE, 0xEF]+ content = "{\"type\": \"blob\", \"value\": [0xDE, 0xAD, 0xBE, 0xEF]}"+ convert' content `shouldBe` Right expected++ it "Validates blob data" $ do+ pending+ convert' "{\"type\": \"blob\", \"value\": [0xFFFF, 0xFF]}" `shouldSatisfy` isLeft+++ describe "parametersParser" $ do+ let convert' = convert parametersParser++ it "Parses hereterogeneous lists" $+ convert' "[1234, \"Hello\", null]" `shouldBe` Right [ P.IntValue 1234+ , P.StringValue "Hello"+ , P.NullValue+ ]++ it "Preserves order" $ do+ convert' "[7, 8]" `shouldBe` Right [ P.IntValue 7, P.IntValue 8 ]+ convert' "[8, 7]" `shouldBe` Right [ P.IntValue 8, P.IntValue 7 ]++ it "Parses empty list" $+ convert' "[]" `shouldBe` Right []++ describe "queryParser" $ do+ let convert' = convert queryParser++ it "Parses query object" $ do+ let content = unlines' [ "{"+ , " \"sql\": \"SELECT * FROM table WHERE a = ? AND b = ?\","+ , " \"params\": [1, \"string\"]"+ , "}"+ ]+ params = [P.IntValue 1, P.StringValue "string"]+ sql = "SELECT * FROM table WHERE a = ? AND b = ?"+ convert' content `shouldBe` Right (sql, params)++ it "Defaults the parameters to empty string" $ do+ let content = unlines' [ "{"+ , " \"sql\": \"SELECT * FROM table\""+ , "}"+ ]+ convert' content `shouldBe` Right ("SELECT * FROM table", [])++ describe "vaultObjectEncoder" $ do+ let serialize' = serialize vaultObjectEncoder++ it "Encodes integer" $+ serialize' (P.IntValue 1) `shouldBe` "1"++ it "Encodes floats" $+ serialize' (P.FloatValue 3.14) `shouldBe` "3.14"++ it "Encodes string" $+ serialize' (P.StringValue "Hello World") `shouldBe` "\"Hello World\""++ it "Preserves the float type for floats without decimals" $ do+ pendingCustomDecimal+ serialize' (P.FloatValue 1.0) `shouldNotBe` "1"++ it "Encodes null" $+ serialize' P.NullValue `shouldBe` "null"++ describe "rowEncoder" $ do+ let serialize' = serialize rowEncoder++ it "Preserves order" $ do+ serialize' [P.IntValue 1, P.NullValue] `shouldBe` "[1,null]"+ serialize' [P.NullValue, P.IntValue 1] `shouldBe` "[null,1]"
+ tests/Festung/FrontendSpec.hs view
@@ -0,0 +1,426 @@+{-# 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
+ tests/Festung/Vault/PersistenceSpec.hs view
@@ -0,0 +1,151 @@+{-# 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]]
+ tests/Festung/Vault/VaultHandlerSpec.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE NamedFieldPuns #-}++module Festung.Vault.VaultHandlerSpec (spec) where+++import Test.Hspec+++import Control.Exception (finally)+import System.FilePath ((</>))++import Festung.Vault.VaultHandler+import qualified Festung.Vault.Persistence as P+import qualified Festung.Concurrency.Job as J++import TestUtils+++defaultPassword :: P.Password+defaultPassword = [0xDE, 0xAD, 0xBE, 0xEE, 0xEE, 0xEE, 0xEF]+++invalidPassword :: P.Password+invalidPassword = [0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00]+++-- | Create a new VaultHandler in a temporary directory+withHandler :: Int -> (VaultOpener -> Vault -> IO a) -> IO a+withHandler timeout action = withConfig timeout $ \ config@Config{dataDirectory} ->+ let vaultPath = dataDirectory </> defaultVaultName+ params = P.VaultParameters { P.kdfIter = Nothing }+ opener = (vaultPath, defaultPassword, params)+ in newHandler config opener >>= action' opener+ where action' o (Left err) = fail' $ expectationFailure ("Could not open handler: " ++ show err)+ action' o (Right v) = finally (action o v) (stopHandler v)+ stopHandler v = return () -- TODO: Really stop the handler+ fail' action = action >> fail "Failed"+++withHandler_ :: (VaultOpener -> Vault -> IO a) -> IO a+withHandler_ = withHandler defaultTimeout+++couldNotReach :: Show a => Either VaultError a -> Expectation+couldNotReach (Right _ ) = expectationFailure "Expected an error"+couldNotReach (Left err) = case err of+ CouldNotReach -> return ()+ _ -> expectationFailure "Expected CouldNotReach"+++spec :: Spec+spec = do+ describe "newHandler" $ do+ it "Can handle many queries" $ withHandler_ $ \ opener vault -> do+ let query' = query opener vault+ query' "CREATE TABLE foo(bar int)"+ query' "INSERT INTO foo(bar) VALUES (1), (2)"++ dat <- noError =<< query' "SELECT bar AS baz FROM foo ORDER BY 1"+ P.headers dat `shouldBe` [("baz", Just "int")]+ P.rows dat `shouldBe` [[P.IntValue 1], [P.IntValue 2]]++ dat <- noError =<< query' "SELECT * FROM foo WHERE bar < 0"+ P.rows dat `shouldBe` []++ it "queries don't block when stopped" $ withHandler_ $ \ opener vault -> do+ J.killJob vault+ couldNotReach =<< query opener vault "SELECT 1"++ it "It verifies password" $ withHandler_ $ \ opener vault -> do+ let (path, password, parameters) = opener+ opener' = (path, invalidPassword, parameters)+ query' = query opener' vault++ ret <- query' "SELECT 1"+ case ret of+ Left CouldNotOpen -> return ()+ Left _ -> expectationFailure "is not CouldNotOpen"+ Right _ -> expectationFailure "is not an error"++ describe "parametrizedQuery" $+ it "Parametrizes the query" $ withHandler_ $ \ opener vault -> do+ let query' = query opener vault+ parametrizedQuery' = parametrizedQuery opener vault++ query' "CREATE TABLE foo(bar int)"+ parametrizedQuery' "INSERT INTO foo(bar) VALUES (?), (?)" [P.IntValue 1, P.IntValue 2]+ dat <- noError =<< parametrizedQuery' "SELECT bar FROM foo WHERE bar < ?" [P.IntValue 2]+ P.headers dat `shouldBe` [("bar", Just "int")]+ P.rows dat `shouldBe` [[P.IntValue 1]]
+ tests/Festung/Vault/VaultManagerSpec.hs view
@@ -0,0 +1,62 @@+module Festung.Vault.VaultManagerSpec (spec) where++import Test.Hspec++import Control.Exception (bracket)+import Control.Monad (forM_)++import Festung.Vault.VaultManager+import qualified Festung.Vault.VaultHandler as V+import qualified Festung.Vault.Persistence as P++import TestUtils+++withManager :: Int -> (VaultManager -> IO a) -> IO a+withManager timeout action = withConfig timeout $ \ config ->+ bracket (newManager config) stopManager action+++withManager_ :: (VaultManager -> IO a) -> IO a+withManager_ = withManager defaultTimeout+++password1 :: P.Password+password1 = [0xDE, 0xAD]++password2 :: P.Password+password2 = [0xBE, 0xEF]+++vault1 :: V.VaultOpener+vault1 = ("vault1.sqlcipher", password1, P.VaultParameters Nothing)++vault2 :: V.VaultOpener+vault2 = ("vault2.sqlcipher", password2, P.VaultParameters (Just 100))+++spec :: Spec+spec =+ describe "newManager" $ do+ it "Can query vault" $ withManager_ $ \ manager -> do+ let query' = query vault1 manager+ query' "CREATE TABLE foo(bar int)"++ dat <- noError =<< query' "SELECT bar FROM foo"+ P.headers dat `shouldBe` [("bar", Just "int")]++ it "Can query different vaults" $ withManager_ $ \ manager -> do+ let dataShouldBe vault dat = do+ dat' <- noError =<< query vault manager "SELECT bar FROM foo ORDER BY 1"+ P.rows dat' `shouldBe` dat++ forM_ [vault1, vault2] $ \ vault -> do+ let query' = query vault manager+ query' "CREATE TABLE foo(bar int)"+ query' "INSERT INTO foo(bar) VALUES (1), (2)"++ vault `dataShouldBe` [[P.IntValue 1], [P.IntValue 2]]++ query vault1 manager "DELETE FROM foo WHERE bar = 1"+ vault1 `dataShouldBe` [[P.IntValue 2]]+ vault2 `dataShouldBe` [[P.IntValue 1], [P.IntValue 2]]
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ tests/TestUtils.hs view
@@ -0,0 +1,68 @@+module TestUtils + ( Config(..)+ , defaultTimeout+ , defaultVaultName+ , isError+ , noError+ , unwrap+ , withConfig+ , withConfig_+ , withTmp+ , withVaultName+ ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.IO.Class (MonadIO)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec (expectationFailure)++import Festung.Config (Config(..))+++withTmp :: (MonadIO m, MonadMask m) => (FilePath -> m a) -> m a+withTmp = withSystemTempDirectory "tmp.test.festung."+++defaultVaultName :: FilePath+defaultVaultName = "vault.sqlcipher"+++withVaultName :: (MonadIO m, MonadMask m) => (FilePath -> m a) -> m a+withVaultName action = withTmp action'+ where action' tmpDir = action $ tmpDir </> defaultVaultName+++unwrap :: Show e => Either e a -> a+unwrap (Left e) = error $ "unwrap: object is an error: " ++ show e+unwrap (Right r) = r+++defaultTimeout :: Int+defaultTimeout = 15 * 1000 * 1000+++-- | Build a temporary configuration+withConfig :: Int -> (Config -> IO a) -> IO a+withConfig timeout action = withTmp $ \ tmpDir ->+ let port = -1 -- Yesod is not running. Port can be anything since it is ignored+ config = Config+ { dataDirectory = tmpDir+ , vaultTimeout = timeout+ , port = port+ }+ in action config+++withConfig_ :: (Config -> IO a) -> IO a+withConfig_ = withConfig defaultTimeout+++noError :: Show a => Either a b -> IO b+noError (Left err) = expectationFailure ("isLeft: " ++ show err) >> fail "Failed"+noError (Right val) = return val+++isError :: Either a b -> IO a+isError (Left err) = return err+isError (Right _) = expectationFailure "isRight" >> fail "Failed"