diff --git a/smash.cabal b/smash.cabal index 0ee6440..9b1f9d3 100644 --- a/smash.cabal +++ b/smash.cabal @@ -21,6 +21,8 @@ source-repository head library exposed-modules: Lib + , Types + , DB other-modules: Paths_smash hs-source-dirs: @@ -28,6 +30,7 @@ library build-depends: base >=4.7 && <5 , cardano-prelude + , containers , servant , servant-server , servant-swagger diff --git a/src/DB.hs b/src/DB.hs new file mode 100644 index 0000000..aaca6fd --- /dev/null +++ b/src/DB.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module DB + ( Configuration (..) + , stubbedConfiguration + , DataLayerError + , DataLayer + , stubbedDataLayer + ) where + +import Cardano.Prelude + +import qualified Data.Map as Map + +import Types + +-- | The basic @Configuration@. +data Configuration = Configuration + { cPortNumber :: !Word + } deriving (Eq, Show) + +stubbedConfiguration :: Configuration +stubbedConfiguration = Configuration 3100 + +-- | Errors, not exceptions. +data DataLayerError + = PoolHashNotFound !PoolHash + deriving (Eq, Show) + +-- | This is the data layer for the DB. +-- The resulting operation has to be @IO@, it can be made more granular, +-- but currently there is no complexity involved for that to be a sane choice. +data DataLayer = DataLayer + { dlGetPoolMetadata :: PoolHash -> IO (Either DataLayerError PoolOfflineMetadata) + , dlAddPoolMetadata :: PoolHash -> PoolOfflineMetadata -> IO (Either DataLayerError PoolOfflineMetadata) + , dlGetBlacklistedPools :: IO (Either DataLayerError [PoolHash]) + , dlAddBlacklistedPool :: PoolHash -> IO (Either DataLayerError PoolHash) + } + +-- | Simple stubbed @DataLayer@ for an example. +-- We do need state here. +stubbedDataLayer :: DataLayer +stubbedDataLayer = DataLayer + { dlGetPoolMetadata = \poolHash -> + case (Map.lookup poolHash stubbedInitialDataMap) of + Just poolHash' -> return $ Right poolHash' + Nothing -> return $ Left (PoolHashNotFound poolHash) + + , dlAddPoolMetadata = \poolHash poolMetadata -> return $ Right poolMetadata -- Right $ Map.insert poolHash poolMetadata stubbedInitialDataMap + , dlGetBlacklistedPools = return $ Right blacklistedPools + , dlAddBlacklistedPool = \poolHash -> return $ Right poolHash + } + +-- The approximation for the table. +stubbedInitialDataMap :: Map PoolHash PoolOfflineMetadata +stubbedInitialDataMap = Map.fromList + [ (createPoolHash "AAAAC3NzaC1lZDI1NTE5AAAAIKFx4CnxqX9mCaUeqp/4EI1+Ly9SfL23/Uxd0Ieegspc", examplePoolOfflineMetadata) + ] + +-- The approximation for the table. +blacklistedPools :: [PoolHash] +blacklistedPools = [] + diff --git a/src/Lib.hs b/src/Lib.hs index b8edf96..c822132 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -11,36 +11,23 @@ module Lib import Cardano.Prelude -import Data.Aeson -import Data.Swagger (Info (..), Swagger (..), - ToParamSchema (..), ToSchema (..), - URL (..)) - -import Network.Wai -import Network.Wai.Handler.Warp - -import Servant +import Data.Swagger (Info (..), Swagger (..)) + +import Network.Wai.Handler.Warp (defaultSettings, runSettings, + setBeforeMainLoop, setPort) + +import Servant ((:<|>) (..), (:>)) +import Servant (Application, BasicAuth, + BasicAuthCheck (..), + BasicAuthData (..), + BasicAuthResult (..), Capture, + Context (..), Get, Handler (..), + JSON, Post, ReqBody, Server, + serveWithContext) import Servant.Swagger --- A data type we use to store user credentials. -data ApplicationUser = ApplicationUser - { username :: !Text - , password :: !Text - } deriving (Eq, Show, Generic) - -instance ToJSON ApplicationUser -instance FromJSON ApplicationUser - --- A list of users we use. -newtype ApplicationUsers = ApplicationUsers [ApplicationUser] - deriving (Eq, Show, Generic) - -instance ToJSON ApplicationUsers -instance FromJSON ApplicationUsers - --- | A user we'll grab from the database when we authenticate someone -newtype User = User { userName :: Text } - deriving (Eq, Show) +import DB +import Types -- The basic auth. type BasicAuthURL = BasicAuth "smash" User @@ -100,26 +87,25 @@ mkApp = return $ serveWithContext (basicAuthServerContext stubbedApplicationUsers) (server stubbedConfiguration stubbedDataLayer) --- | A list of users with very original passwords. -stubbedApplicationUsers :: ApplicationUsers -stubbedApplicationUsers = ApplicationUsers [ApplicationUser "ksaric" "cirask"] - -- | We need to supply our handlers with the right Context. basicAuthServerContext :: ApplicationUsers -> Context (BasicAuthCheck User ': '[]) basicAuthServerContext applicationUsers = (authCheck applicationUsers) :. EmptyContext where -- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. authCheck :: ApplicationUsers -> BasicAuthCheck User - authCheck (ApplicationUsers applicationUsers') = + authCheck applicationUsers' = let check :: BasicAuthData -> IO (BasicAuthResult User) - check (BasicAuthData username password) = - if (ApplicationUser usernameText passwordText) `elem` applicationUsers' - then pure (Authorized (User usernameText)) - else pure Unauthorized - where - usernameText = decodeUtf8 username - passwordText = decodeUtf8 password + check (BasicAuthData username password) = do + let usernameText = decodeUtf8 username + let passwordText = decodeUtf8 password + + let applicationUser = ApplicationUser usernameText passwordText + let userAuthValidity = checkIfUserValid applicationUsers' applicationUser + + case userAuthValidity of + UserValid user -> pure (Authorized user) + UserInvalid -> pure Unauthorized in BasicAuthCheck check @@ -130,10 +116,10 @@ convertIOToHandler = Handler . ExceptT . try -- | Combined server of a Smash service with Swagger documentation. server :: Configuration -> DataLayer -> Server API --Server SmashAPI -server configuration dataLayer = - return todoSwagger - :<|> getPoolOfflineMetadata - :<|> postBlacklistPool +server configuration dataLayer + = return todoSwagger + :<|> getPoolOfflineMetadata + :<|> postBlacklistPool postBlacklistPool :: User -> BlacklistPool -> Handler PoolOfflineMetadata postBlacklistPool user blacklistPool = convertIOToHandler $ do @@ -146,148 +132,12 @@ getPoolOfflineMetadata poolHash = convertIOToHandler $ do putTextLn $ show poolHash return examplePoolOfflineMetadata - --- | The basic @Configuration@. -data Configuration = Configuration - { cPortNumber :: !Word - } deriving (Eq, Show) - -stubbedConfiguration :: Configuration -stubbedConfiguration = Configuration 3100 - -data DataLayerError - = PoolHashNotFound !PoolHash - deriving (Eq, Show) - --- | This is the data layer for the DB. -data DataLayer = DataLayer - { dlGetPoolHash :: PoolHash -> Either DataLayerError PoolOfflineMetadata - } - --- | Simple stubbed @DataLayer@ for an example. -stubbedDataLayer :: DataLayer -stubbedDataLayer = DataLayer - { dlGetPoolHash = \_ -> Right examplePoolOfflineMetadata - } - -examplePoolOfflineMetadata :: PoolOfflineMetadata -examplePoolOfflineMetadata = - PoolOfflineMetadata - (PoolName "TestPool") - (PoolDescription "This is a pool for testing") - (PoolTicker "testp") - (PoolHomepage "https://iohk.io") - --- "name":{ --- "type":"string", --- "minLength":1, --- "maxLength":50 --- }, --- "description":{ --- "type":"string", --- "minLength":1, --- "maxLength":255 --- }, --- "ticker":{ --- "type":"string", --- "minLength":3, --- "maxLength":5, --- "pattern":"^[A-Z0-9]{3,5}$" --- }, --- "homepage":{ --- "type":"string", --- "format":"uri", --- "pattern":"^https://" --- }, - -- | Here for checking the validity of the data type. --isValidPoolOfflineMetadata :: PoolOfflineMetadata -> Bool --isValidPoolOfflineMetadata poolOfflineMetadata = -- poolOfflineMetadata -- TODO(KS): Validation!? -newtype BlacklistPool = BlacklistPool - { blacklistPool :: Text - } deriving (Eq, Show, Generic) - -instance FromJSON BlacklistPool -instance ToJSON BlacklistPool - -instance ToSchema BlacklistPool - --- | Submissions are identified by the subject's Bech32-encoded Ed25519 public key (all lowercase). --- ed25519_pk1z2ffur59cq7t806nc9y2g64wa60pg5m6e9cmrhxz9phppaxk5d4sn8nsqg -newtype PoolHash = PoolHash - { getPoolHash :: Text - } deriving (Eq, Show, Generic) - -instance ToParamSchema PoolHash - --- TODO(KS): Temporarily, validation!? -instance FromHttpApiData PoolHash where - parseUrlPiece poolHashText = - if (isPrefixOf "ed25519_" (toS poolHashText)) - then Right $ PoolHash poolHashText - else Left "PoolHash not starting with 'ed25519_'!" - -newtype PoolName = PoolName - { getPoolName :: Text - } deriving (Eq, Show, Generic) - -instance ToSchema PoolName - -newtype PoolDescription = PoolDescription - { getPoolDescription :: Text - } deriving (Eq, Show, Generic) - -instance ToSchema PoolDescription - -newtype PoolTicker = PoolTicker - { getPoolTicker :: Text - } deriving (Eq, Show, Generic) - -instance ToSchema PoolTicker - -newtype PoolHomepage = PoolHomepage - { getPoolHomepage :: Text - } deriving (Eq, Show, Generic) - -instance ToSchema PoolHomepage - -data PoolOfflineMetadata = PoolOfflineMetadata - { name :: !PoolName - , description :: !PoolDescription - , ticker :: !PoolTicker - , homepage :: !PoolHomepage - } deriving (Eq, Show, Generic) - --- Required instances -instance FromJSON PoolOfflineMetadata where - parseJSON = withObject "poolOfflineMetadata" $ \o -> do - name' <- o .: "name" - description' <- o .: "description" - ticker' <- o .: "ticker" - homepage' <- o .: "homepage" - - return $ PoolOfflineMetadata - { name = PoolName name' - , description = PoolDescription description' - , ticker = PoolTicker ticker' - , homepage = PoolHomepage homepage' - } - -instance ToJSON PoolOfflineMetadata where - toJSON (PoolOfflineMetadata name' description' ticker' homepage') = - object - [ "name" .= getPoolName name' - , "description" .= getPoolDescription description' - , "ticker" .= getPoolTicker ticker' - , "homepage" .= getPoolHomepage homepage' - ] - ---instance ToParamSchema PoolOfflineMetadata -instance ToSchema PoolOfflineMetadata - -- For now, we just ignore the @BasicAuth@ definition. instance (HasSwagger api) => HasSwagger (BasicAuth name typo :> api) where toSwagger _ = toSwagger (Proxy :: Proxy api) diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..788aa10 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Types + ( ApplicationUser (..) + , ApplicationUsers + , stubbedApplicationUsers + , User + , UserValidity (..) + , checkIfUserValid + -- * Pool info + , BlacklistPool + , PoolHash + , createPoolHash + -- * Pool offline metadata + , PoolName + , PoolDescription + , PoolTicker + , PoolHomepage + , PoolOfflineMetadata + , examplePoolOfflineMetadata + -- * Pool online data + , PoolOnlineData + , PoolOwner + , PoolPledgeAddress + , examplePoolOnlineData + ) where + +import Cardano.Prelude + +import Data.Aeson +import Data.Swagger (ToParamSchema (..), ToSchema (..)) + +import Servant (FromHttpApiData (..)) + +-- | A list of users with very original passwords. +stubbedApplicationUsers :: ApplicationUsers +stubbedApplicationUsers = ApplicationUsers [ApplicationUser "ksaric" "cirask"] + +examplePoolOfflineMetadata :: PoolOfflineMetadata +examplePoolOfflineMetadata = + PoolOfflineMetadata + (PoolName "TestPool") + (PoolDescription "This is a pool for testing") + (PoolTicker "testp") + (PoolHomepage "https://iohk.io") + +examplePoolOnlineData :: PoolOnlineData +examplePoolOnlineData = + PoolOnlineData + (PoolOwner "ed25519_pk1jfuzzwhsrvq52aj7lec725vrnfkcprufcghj7jr9g7e6cx3eqp3qc89fl4") + (PoolPledgeAddress "e8080fd3b5b5c9fcd62eb9cccbef9892dd74dacf62d79a9e9e67a79afa3b1207") + +-- A data type we use to store user credentials. +data ApplicationUser = ApplicationUser + { username :: !Text + , password :: !Text + } deriving (Eq, Show, Generic) + +instance ToJSON ApplicationUser +instance FromJSON ApplicationUser + +-- A list of users we use. +newtype ApplicationUsers = ApplicationUsers [ApplicationUser] + deriving (Eq, Show, Generic) + +instance ToJSON ApplicationUsers +instance FromJSON ApplicationUsers + +-- | A user we'll grab from the database when we authenticate someone +newtype User = User { userName :: Text } + deriving (Eq, Show) + +-- | This we can leak. +data UserValidity + = UserValid !User + | UserInvalid + deriving (Eq, Show) + +-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password. +checkIfUserValid :: ApplicationUsers -> ApplicationUser -> UserValidity +checkIfUserValid (ApplicationUsers applicationUsers) applicationUser@(ApplicationUser usernameText _) = + if applicationUser `elem` applicationUsers + then (UserValid (User usernameText)) + else UserInvalid + +newtype BlacklistPool = BlacklistPool + { blacklistPool :: Text + } deriving (Eq, Show, Generic) + +instance FromJSON BlacklistPool +instance ToJSON BlacklistPool + +instance ToSchema BlacklistPool + +-- | We use base64 encoding here. +-- Submissions are identified by the subject's Bech32-encoded Ed25519 public key (all lowercase). +-- An Ed25519 public key is a 64-byte string. We'll typically show such string in base16. +-- base64 is fine too, more concise. But bech32 is definitely overkill here. +-- This might be a synonym for @PoolOwner@. +newtype PoolHash = PoolHash + { getPoolHash :: Text + } deriving (Eq, Show, Ord, Generic) + +instance ToParamSchema PoolHash + +-- | Should be an @Either@. +createPoolHash :: Text -> PoolHash +createPoolHash hash = PoolHash hash + +-- TODO(KS): Temporarily, validation!? +instance FromHttpApiData PoolHash where + parseUrlPiece poolHashText = Right $ PoolHash poolHashText + +-- if (isPrefixOf "ed25519_" (toS poolHashText)) +-- then Right $ PoolHash poolHashText +-- else Left "PoolHash not starting with 'ed25519_'!" + +newtype PoolName = PoolName + { getPoolName :: Text + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PoolName + +newtype PoolDescription = PoolDescription + { getPoolDescription :: Text + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PoolDescription + +newtype PoolTicker = PoolTicker + { getPoolTicker :: Text + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PoolTicker + +newtype PoolHomepage = PoolHomepage + { getPoolHomepage :: Text + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PoolHomepage + +-- | The bit of the pool data off the chain. +data PoolOfflineMetadata = PoolOfflineMetadata + { pomName :: !PoolName + , pomDescription :: !PoolDescription + , pomTicker :: !PoolTicker + , pomHomepage :: !PoolHomepage + } deriving (Eq, Show, Ord, Generic) + +newtype PoolOwner = PoolOwner + { getPoolOwner :: Text + } deriving (Eq, Show, Ord, Generic) + +newtype PoolPledgeAddress = PoolPledgeAddress + { getPoolPledgeAddress :: Text + } deriving (Eq, Show, Ord, Generic) + +-- | The bit of the pool data on the chain. +-- This doesn't leave the internal database. +data PoolOnlineData = PoolOnlineData + { podOwner :: !PoolOwner + , podPledgeAddress :: !PoolPledgeAddress + } deriving (Eq, Show, Ord, Generic) + +-- Required instances +instance FromJSON PoolOfflineMetadata where + parseJSON = withObject "poolOfflineMetadata" $ \o -> do + name' <- o .: "name" + description' <- o .: "description" + ticker' <- o .: "ticker" + homepage' <- o .: "homepage" + + return $ PoolOfflineMetadata + { pomName = PoolName name' + , pomDescription = PoolDescription description' + , pomTicker = PoolTicker ticker' + , pomHomepage = PoolHomepage homepage' + } + +instance ToJSON PoolOfflineMetadata where + toJSON (PoolOfflineMetadata name' description' ticker' homepage') = + object + [ "name" .= getPoolName name' + , "description" .= getPoolDescription description' + , "ticker" .= getPoolTicker ticker' + , "homepage" .= getPoolHomepage homepage' + ] + +--instance ToParamSchema PoolOfflineMetadata +instance ToSchema PoolOfflineMetadata +