Frontend.hs

{-# 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 ()