Converters.hs

{-# 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 ] ]