diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,3 @@ +This project is not supposed to be public. + +(C) All right are reserved by Figo GmbH. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,109 @@ +# Festung + +Remote multi-db SQLCipher server exposing a REST API + +![](https://upload.wikimedia.org/wikipedia/commons/c/c1/SenjNehajgrad0.jpg) + +## 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 +} +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/festung.cabal b/festung.cabal new file mode 100644 --- /dev/null +++ b/festung.cabal @@ -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 diff --git a/prog/Main.hs b/prog/Main.hs new file mode 100644 --- /dev/null +++ b/prog/Main.hs @@ -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 diff --git a/src/Festung/Concurrency/Gig.hs b/src/Festung/Concurrency/Gig.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Concurrency/Gig.hs @@ -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 diff --git a/src/Festung/Concurrency/Job.hs b/src/Festung/Concurrency/Job.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Concurrency/Job.hs @@ -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) diff --git a/src/Festung/Concurrency/Utils.hs b/src/Festung/Concurrency/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Concurrency/Utils.hs @@ -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 diff --git a/src/Festung/Config.hs b/src/Festung/Config.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Config.hs @@ -0,0 +1,7 @@ +module Festung.Config (Config(..)) where + + +data Config = Config { dataDirectory :: String + , vaultTimeout :: Int + , port :: Int + } diff --git a/src/Festung/Frontend.hs b/src/Festung/Frontend.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Frontend.hs @@ -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 () diff --git a/src/Festung/Frontend/Converters.hs b/src/Festung/Frontend/Converters.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Frontend/Converters.hs @@ -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 ] ] diff --git a/src/Festung/Frontend/Validators.hs b/src/Festung/Frontend/Validators.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Frontend/Validators.hs @@ -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) + -- + -- 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) + ] diff --git a/src/Festung/Utils.hs b/src/Festung/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Utils.hs @@ -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 () diff --git a/src/Festung/Vault.hs b/src/Festung/Vault.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Vault.hs @@ -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 diff --git a/src/Festung/Vault/Persistence.hs b/src/Festung/Vault/Persistence.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Vault/Persistence.hs @@ -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 diff --git a/src/Festung/Vault/VaultHandler.hs b/src/Festung/Vault/VaultHandler.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Vault/VaultHandler.hs @@ -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 diff --git a/src/Festung/Vault/VaultManager.hs b/src/Festung/Vault/VaultManager.hs new file mode 100644 --- /dev/null +++ b/src/Festung/Vault/VaultManager.hs @@ -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 diff --git a/tests/Festung/Concurrency/GigSpec.hs b/tests/Festung/Concurrency/GigSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Concurrency/GigSpec.hs @@ -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 diff --git a/tests/Festung/Concurrency/JobSpec.hs b/tests/Festung/Concurrency/JobSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Concurrency/JobSpec.hs @@ -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 diff --git a/tests/Festung/Concurrency/UtilsSpec.hs b/tests/Festung/Concurrency/UtilsSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Concurrency/UtilsSpec.hs @@ -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 diff --git a/tests/Festung/Frontend/ConvertersSpec.hs b/tests/Festung/Frontend/ConvertersSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Frontend/ConvertersSpec.hs @@ -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]" diff --git a/tests/Festung/FrontendSpec.hs b/tests/Festung/FrontendSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/FrontendSpec.hs @@ -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 diff --git a/tests/Festung/Vault/PersistenceSpec.hs b/tests/Festung/Vault/PersistenceSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Vault/PersistenceSpec.hs @@ -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]] diff --git a/tests/Festung/Vault/VaultHandlerSpec.hs b/tests/Festung/Vault/VaultHandlerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Vault/VaultHandlerSpec.hs @@ -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]] diff --git a/tests/Festung/Vault/VaultManagerSpec.hs b/tests/Festung/Vault/VaultManagerSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Festung/Vault/VaultManagerSpec.hs @@ -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]] diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/TestUtils.hs @@ -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"