diff --git a/schema/migration-2-0001-20200611.sql b/schema/migration-2-0001-20200615.sql similarity index 100% rename from schema/migration-2-0001-20200611.sql rename to schema/migration-2-0001-20200615.sql diff --git a/src/DB.hs b/src/DB.hs index c8371a4..f0e7faf 100644 --- a/src/DB.hs +++ b/src/DB.hs @@ -17,11 +17,11 @@ module DB import Cardano.Prelude -import Data.Aeson (encode, eitherDecode) +import Data.Aeson (eitherDecode) import qualified Data.Map as Map import Data.IORef (IORef, readIORef, modifyIORef) -import qualified Data.ByteString as BS +import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL import Types @@ -46,11 +46,9 @@ import Cardano.Db.Error as X -- but currently there is no complexity involved for that to be a sane choice. data DataLayer = DataLayer { dlGetPoolMetadataSimple :: PoolHash -> IO (Either DBFail Text) - --{ dlGetPoolMetadataSimple :: PoolHash -> IO (Either DBFail ByteString) , dlGetPoolMetadata :: PoolHash -> IO (Either DBFail PoolOfflineMetadata) , dlAddPoolMetadata :: PoolHash -> PoolOfflineMetadata -> IO (Either DBFail PoolOfflineMetadata) , dlAddPoolMetadataSimple :: PoolHash -> Text -> IO (Either DBFail TxMetadataId) - --, dlAddPoolMetadataSimple :: PoolHash -> ByteString -> IO (Either DBFail TxMetadataId) , dlGetBlacklistedPools :: IO (Either DBFail [PoolHash]) , dlAddBlacklistedPool :: PoolHash -> IO (Either DBFail PoolHash) } @@ -111,10 +109,6 @@ postgresqlDataLayer = DataLayer let metadata :: Text metadata = txMetadataMetadata txMetadata - --BS.putStrLn metadata - --putTextLn $ decodeUtf8 metadata - - --return $ first (\m -> UnknownError (toS m)) $ eitherDecode $ BL.fromStrict metadata return $ first (\m -> UnknownError (toS m)) $ eitherDecode $ BL.fromStrict (encodeUtf8 metadata) , dlGetPoolMetadataSimple = \poolHash -> do @@ -124,14 +118,18 @@ postgresqlDataLayer = DataLayer , dlAddPoolMetadata = \poolHash poolMetadata -> panic "To implement!" , dlAddPoolMetadataSimple = \poolHash poolMetadata -> do + --putTextLn poolMetadata let poolHashBytestring = (encodeUtf8 $ getPoolHash poolHash) - let poolEncodedMetadata = poolMetadata - let hashFromMetadata = B16.encode $ Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) $ (encodeUtf8 poolEncodedMetadata) + let hashFromMetadata = B16.encode $ Crypto.digest (Proxy :: Proxy Crypto.Blake2b_256) (encodeUtf8 poolMetadata) + + putTextLn poolMetadata - when (hashFromMetadata /= poolHashBytestring) $ - panic "TxMetadataHashMismatch" + -- Let us just ignore the newlines. + let cleanPoolMetadata = T.unwords . T.lines $ poolMetadata - fmap Right $ runDbAction Nothing $ insertTxMetadata $ TxMetadata poolHashBytestring poolEncodedMetadata + if hashFromMetadata /= poolHashBytestring + then return $ Left TxMetadataHashMismatch + else fmap Right $ runDbAction Nothing $ insertTxMetadata $ TxMetadata poolHashBytestring cleanPoolMetadata , dlGetBlacklistedPools = panic "To implement!" , dlAddBlacklistedPool = \poolHash -> panic "To implement!" diff --git a/src/Lib.hs b/src/Lib.hs index b4a4e11..35e3319 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -10,15 +10,14 @@ module Lib , DBFail (..) -- We need to see errors clearly outside , defaultConfiguration , runApp + , runAppStubbed , runPoolInsertion ) where import Cardano.Prelude -import qualified Data.ByteString as B import Data.IORef (newIORef) -import Data.Swagger (Info (..), Swagger (..), ToSchema) - +import Data.Swagger (Info (..), Swagger (..)) import Network.Wai.Handler.Warp (defaultSettings, runSettings, setBeforeMainLoop, setPort) @@ -39,8 +38,11 @@ import Types -- The basic auth. type BasicAuthURL = BasicAuth "smash" User +-- | Shortcut for common api result types. +type ApiRes verb a = verb '[JSON] (Either DBFail a) + -- GET api/v1/metadata/{hash} -type OfflineMetadataAPI = "api" :> "v1" :> "metadata" :> Capture "hash" PoolHash :> Get '[JSON] PoolMetadataWrapped +type OfflineMetadataAPI = "api" :> "v1" :> "metadata" :> Capture "hash" PoolHash :> ApiRes Get PoolMetadataWrapped -- POST api/v1/blacklist |-> {"blacklistPool" : "pool"} type BlacklistPoolAPI = BasicAuthURL :> "api" :> "v1" :> "blacklist" :> ReqBody '[JSON] BlacklistPool :> Post '[JSON] PoolOfflineMetadata @@ -89,6 +91,16 @@ runApp configuration = do runSettings settings =<< mkApp configuration +runAppStubbed :: Configuration -> IO () +runAppStubbed configuration = do + let port = cPortNumber configuration + let settings = + setPort port $ + setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) $ + defaultSettings + + runSettings settings =<< mkAppStubbed configuration + mkAppStubbed :: Configuration -> IO Application mkAppStubbed configuration = do @@ -168,11 +180,11 @@ postBlacklistPool user blacklistPool = convertIOToHandler $ do return examplePoolOfflineMetadata -- throwError err404 -getPoolOfflineMetadata :: DataLayer -> PoolHash -> Handler PoolMetadataWrapped +getPoolOfflineMetadata :: DataLayer -> PoolHash -> Handler (Either DBFail PoolMetadataWrapped) getPoolOfflineMetadata dataLayer poolHash = convertIOToHandler $ do - putTextLn $ show poolHash - fmap PoolMetadataWrapped $ either (\m -> panic $ renderLookupFail m) (\a -> a) <$> (dlGetPoolMetadataSimple dataLayer) poolHash - --(dlGetPoolMetadataSimple dataLayer) poolHash + let getPoolMetadataSimple = dlGetPoolMetadataSimple dataLayer + poolMetadata <- getPoolMetadataSimple poolHash + return $ PoolMetadataWrapped <$> poolMetadata -- | Here for checking the validity of the data type. --isValidPoolOfflineMetadata :: PoolOfflineMetadata -> Bool diff --git a/src/Types.hs b/src/Types.hs index 1588322..cfcc30d 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} module Types ( ApplicationUser (..) @@ -33,13 +33,16 @@ module Types import Cardano.Prelude -import Data.Aeson -import Data.Swagger (ToParamSchema (..), ToSchema (..), NamedSchema (..), declareSchemaRef) +import Data.Aeson (FromJSON (..), ToJSON (..), object, + withObject, (.:), (.=)) +import Data.Aeson.Encoding (unsafeToEncoding) +import Data.Swagger (NamedSchema (..), ToParamSchema (..), + ToSchema (..)) +import Data.Text.Encoding (encodeUtf8Builder) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL +import Servant (FromHttpApiData (..)) -import Servant (FromHttpApiData (..)) +import Cardano.Db.Error -- | The basic @Configuration@. data Configuration = Configuration @@ -158,10 +161,10 @@ instance ToSchema PoolHomepage -- | The bit of the pool data off the chain. data PoolOfflineMetadata = PoolOfflineMetadata - { pomName :: !PoolName - , pomDescription :: !PoolDescription - , pomTicker :: !PoolTicker - , pomHomepage :: !PoolHomepage + { pomName :: !PoolName + , pomDescription :: !PoolDescription + , pomTicker :: !PoolTicker + , pomHomepage :: !PoolHomepage } deriving (Eq, Show, Ord, Generic) -- | Smart constructor, just adding one more layer of indirection. @@ -184,8 +187,8 @@ newtype PoolPledgeAddress = PoolPledgeAddress -- | The bit of the pool data on the chain. -- This doesn't leave the internal database. data PoolOnlineData = PoolOnlineData - { podOwner :: !PoolOwner - , podPledgeAddress :: !PoolPledgeAddress + { podOwner :: !PoolOwner + , podPledgeAddress :: !PoolPledgeAddress } deriving (Eq, Show, Ord, Generic) -- Required instances @@ -217,16 +220,19 @@ instance ToSchema PoolOfflineMetadata newtype PoolMetadataWrapped = PoolMetadataWrapped Text - deriving (Eq, Show, Ord, Generic) + deriving (Eq, Ord, Show, Generic) +-- Here we are usingg the unsafe encoding since we already have the JSON format +-- from the database. instance ToJSON PoolMetadataWrapped where - --toJSON (PoolMetadataWrapped hash) = toJSON $ (either (\_ -> panic "Error") (\a -> a) (eitherDecode $ BL.fromStrict $ encodeUtf8 hash) :: PoolOfflineMetadata) - - toJSON (PoolMetadataWrapped hash) = String $ hash - --toJSON (PoolMetadataWrapped hash) = String $ decodeUtf8 hash + toJSON (PoolMetadataWrapped metadata) = toJSON metadata + toEncoding (PoolMetadataWrapped metadata) = unsafeToEncoding $ encodeUtf8Builder metadata instance ToSchema PoolMetadataWrapped where declareNamedSchema _ = return $ NamedSchema (Just "PoolMetadataWrapped") $ mempty +instance ToSchema DBFail where + declareNamedSchema _ = + return $ NamedSchema (Just "DBFail") $ mempty