Merge pull request #7 from input-output-hk/ksaric/CAD-777

[CAD-777] Add simple tests.

.gitignore

@@ -1,3 +1,4 @@
 .stack-work/
 dist-newstyle/
 *~
+tags

app/Main.hs

@@ -5,4 +5,4 @@ import           Cardano.Prelude
 import           Lib
 
 main :: IO ()
-main = runApp
+main = runApp defaultConfiguration

smash.cabal

@@ -76,12 +76,18 @@ test-suite smash-test
   main-is: Spec.hs
   other-modules:
       Paths_smash
+    , SmashSpec
   hs-source-dirs:
       test
   ghc-options: -threaded -rtsopts -with-rtsopts=-N
   build-depends:
       base >=4.7 && <5
+    , cardano-prelude
     , smash
+    , hspec
+    , QuickCheck
+    -- * Required for generation of keys
+    , ed25519
   default-language:    Haskell2010
   default-extensions:  NoImplicitPrelude
                        OverloadedStrings

src/DB.hs

@@ -6,27 +6,21 @@
 {-# LANGUAGE TypeOperators       #-}
 
 module DB
-    ( Configuration (..)
-    , stubbedConfiguration
-    , DataLayerError
-    , DataLayer
+    ( DataLayerError
+    , DataLayer (..)
     , stubbedDataLayer
+    -- * Examples
+    , stubbedInitialDataMap
+    , stubbedBlacklistedPools
     ) where
 
 import           Cardano.Prelude
 
 import qualified Data.Map as Map
+import           Data.IORef (IORef, readIORef, modifyIORef)
 
 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
@@ -43,17 +37,34 @@ data DataLayer = DataLayer
     }
 
 -- | 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)
+-- We do need state here. _This thing is thread safe._
+-- __This is really our model here.__
+stubbedDataLayer
+    :: IORef (Map PoolHash PoolOfflineMetadata)
+    -> IORef [PoolHash]
+    -> DataLayer
+stubbedDataLayer ioDataMap ioBlacklistedPool = DataLayer
+    { dlGetPoolMetadata     = \poolHash -> do
+        ioDataMap' <- readIORef ioDataMap
+        case (Map.lookup poolHash ioDataMap') of
+            Just poolOfflineMetadata'   -> return $ Right poolOfflineMetadata'
+            Nothing                     -> return $ Left (PoolHashNotFound poolHash)
+
+    , dlAddPoolMetadata     = \poolHash poolMetadata -> do
+        -- TODO(KS): What if the pool metadata already exists?
+        _ <- modifyIORef ioDataMap (\dataMap -> Map.insert poolHash poolMetadata dataMap)
+        return $ Right poolMetadata
+
+    , dlGetBlacklistedPools = do
+        blacklistedPool <- readIORef ioBlacklistedPool
+        return $ Right blacklistedPool
+
+    , dlAddBlacklistedPool  = \poolHash -> do
+        _ <- modifyIORef ioBlacklistedPool (\pool -> [poolHash] ++ pool)
+        -- TODO(KS): Do I even need to query this?
+        blacklistedPool <- readIORef ioBlacklistedPool
+        return $ Right 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.
@@ -63,6 +74,6 @@ stubbedInitialDataMap = Map.fromList
     ]
 
 -- The approximation for the table.
-blacklistedPools :: [PoolHash]
-blacklistedPools = []
+stubbedBlacklistedPools :: [PoolHash]
+stubbedBlacklistedPools = []
 

src/Lib.hs

@@ -6,13 +6,17 @@
 {-# LANGUAGE TypeOperators       #-}
 
 module Lib
-    ( runApp
+    ( Configuration (..)
+    , defaultConfiguration
+    , runApp
     ) where
 
 import           Cardano.Prelude
 
+import           Data.IORef               (newIORef)
 import           Data.Swagger             (Info (..), Swagger (..))
 
+
 import           Network.Wai.Handler.Warp (defaultSettings, runSettings,
                                            setBeforeMainLoop, setPort)
 
@@ -72,20 +76,29 @@ smashApi = Proxy
 -- 404 if it is not available (e.g. it could not be downloaded, or was invalid)
 -- 200 with the JSON content. Note that this must be the original content with the expected hash, not a re-rendering of the original.
 
-runApp :: IO ()
-runApp = do
-    let port = 3000
-        settings =
+runApp :: Configuration -> IO ()
+runApp configuration = do
+    let port = cPortNumber configuration
+    let settings =
           setPort port $
           setBeforeMainLoop (hPutStrLn stderr ("listening on port " ++ show port)) $
           defaultSettings
-    runSettings settings =<< mkApp
 
-mkApp :: IO Application
-mkApp = return $ serveWithContext
-            fullAPI
-            (basicAuthServerContext stubbedApplicationUsers)
-            (server stubbedConfiguration stubbedDataLayer)
+    runSettings settings =<< mkApp configuration
+
+mkApp :: Configuration -> IO Application
+mkApp configuration = do
+
+    ioDataMap           <- newIORef stubbedInitialDataMap
+    ioBlacklistedPools  <- newIORef stubbedBlacklistedPools
+
+    let dataLayer :: DataLayer
+        dataLayer = stubbedDataLayer ioDataMap ioBlacklistedPools
+
+    return $ serveWithContext
+        fullAPI
+        (basicAuthServerContext stubbedApplicationUsers)
+        (server configuration dataLayer)
 
 -- | We need to supply our handlers with the right Context.
 basicAuthServerContext :: ApplicationUsers -> Context (BasicAuthCheck User ': '[])
@@ -95,8 +108,8 @@ basicAuthServerContext applicationUsers = (authCheck applicationUsers) :. EmptyC
     authCheck :: ApplicationUsers -> BasicAuthCheck User
     authCheck applicationUsers' =
 
-        let check :: BasicAuthData -> IO (BasicAuthResult User)
-            check (BasicAuthData username password) = do
+        let check' :: BasicAuthData -> IO (BasicAuthResult User)
+            check' (BasicAuthData username password) = do
                 let usernameText = decodeUtf8 username
                 let passwordText = decodeUtf8 password
 
@@ -107,7 +120,7 @@ basicAuthServerContext applicationUsers = (authCheck applicationUsers) :. EmptyC
                     UserValid user -> pure (Authorized user)
                     UserInvalid    -> pure Unauthorized
 
-        in BasicAuthCheck check
+        in BasicAuthCheck check'
 
 
 -- | Natural transformation from @IO@ to @Handler@.

src/Types.hs

@@ -12,17 +12,21 @@ module Types
     , PoolHash
     , createPoolHash
     -- * Pool offline metadata
-    , PoolName
-    , PoolDescription
-    , PoolTicker
-    , PoolHomepage
+    , PoolName (..)
+    , PoolDescription (..)
+    , PoolTicker (..)
+    , PoolHomepage (..)
     , PoolOfflineMetadata
+    , createPoolOfflineMetadata
     , examplePoolOfflineMetadata
     -- * Pool online data
     , PoolOnlineData
     , PoolOwner
     , PoolPledgeAddress
     , examplePoolOnlineData
+    -- * Configuration
+    , Configuration (..)
+    , defaultConfiguration
     ) where
 
 import           Cardano.Prelude
@@ -32,6 +36,14 @@ import           Data.Swagger    (ToParamSchema (..), ToSchema (..))
 
 import           Servant         (FromHttpApiData (..))
 
+-- | The basic @Configuration@.
+data Configuration = Configuration
+    { cPortNumber :: !Int
+    } deriving (Eq, Show)
+
+defaultConfiguration :: Configuration
+defaultConfiguration = Configuration 3100
+
 -- | A list of users with very original passwords.
 stubbedApplicationUsers :: ApplicationUsers
 stubbedApplicationUsers = ApplicationUsers [ApplicationUser "ksaric" "cirask"]
@@ -47,7 +59,7 @@ examplePoolOfflineMetadata =
 examplePoolOnlineData :: PoolOnlineData
 examplePoolOnlineData =
     PoolOnlineData
-        (PoolOwner "ed25519_pk1jfuzzwhsrvq52aj7lec725vrnfkcprufcghj7jr9g7e6cx3eqp3qc89fl4")
+        (PoolOwner "AAAAC3NzaC1lZDI1NTE5AAAAIKFx4CnxqX9mCaUeqp/4EI1+Ly9SfL23/Uxd0Ieegspc")
         (PoolPledgeAddress "e8080fd3b5b5c9fcd62eb9cccbef9892dd74dacf62d79a9e9e67a79afa3b1207")
 
 -- A data type we use to store user credentials.
@@ -147,6 +159,15 @@ data PoolOfflineMetadata = PoolOfflineMetadata
     , pomHomepage       :: !PoolHomepage
     } deriving (Eq, Show, Ord, Generic)
 
+-- | Smart constructor, just adding one more layer of indirection.
+createPoolOfflineMetadata
+    :: PoolName
+    -> PoolDescription
+    -> PoolTicker
+    -> PoolHomepage
+    -> PoolOfflineMetadata
+createPoolOfflineMetadata = PoolOfflineMetadata
+
 newtype PoolOwner = PoolOwner
     { getPoolOwner :: Text
     } deriving (Eq, Show, Ord, Generic)

stack.yaml

@@ -47,8 +47,6 @@ extra-deps:
       - .
       - test
 
-
-
 # Override default flag values for local packages and extra-deps
 # flags: {}
 

test/SmashSpec.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module SmashSpec
+    ( smashSpec
+    ) where
+
+import           Cardano.Prelude
+
+import           Crypto.Sign.Ed25519     (createKeypair)
+import           Data.IORef              (IORef, newIORef)
+
+import           Test.Hspec              (Spec, describe, it)
+import           Test.Hspec.QuickCheck   (modifyMaxSuccess, prop)
+import           Test.QuickCheck         (Arbitrary (..), Gen, Property,
+                                          elements, generate, listOf)
+import           Test.QuickCheck.Monadic (assert, monadicIO, run)
+
+import           DB
+import           Types
+
+-- | Test spec for smash
+smashSpec :: Spec
+smashSpec = do
+    describe "DataLayer" $ do
+        describe "Blacklisted pool" $
+            prop "adding a pool hash adds it to the data layer" $ monadicIO $ do
+
+                (pk, _)             <- run $ createKeypair
+
+                let newPoolHash :: PoolHash
+                    newPoolHash = createPoolHash . show $ pk
+
+                ioDataMap           <- run $ newIORef stubbedInitialDataMap
+                ioBlacklistedPools  <- run $ newIORef stubbedBlacklistedPools
+
+                let dataLayer :: DataLayer
+                    dataLayer = stubbedDataLayer ioDataMap ioBlacklistedPools
+
+                newBlacklistPoolState <- run $ (dlAddBlacklistedPool dataLayer) newPoolHash
+
+                newBlacklistedPools   <- run $ dlGetBlacklistedPools dataLayer
+
+                assert $ isRight newBlacklistPoolState
+                assert $ isRight newBlacklistedPools
+
+                assert $ newBlacklistedPools == Right (newPoolHash : stubbedBlacklistedPools)
+
+        describe "Pool metadata" $ do
+            prop "adding a pool metadata and returning the same" $ \(poolOfflineMetadata) -> monadicIO $ do
+
+                (pk, _)             <- run $ createKeypair
+
+                let newPoolHash :: PoolHash
+                    newPoolHash = createPoolHash . show $ pk
+
+                ioDataMap           <- run $ newIORef stubbedInitialDataMap
+                ioBlacklistedPools  <- run $ newIORef stubbedBlacklistedPools
+
+                let dataLayer :: DataLayer
+                    dataLayer = stubbedDataLayer ioDataMap ioBlacklistedPools
+
+                newPoolOfflineMetadata  <- run $ (dlAddPoolMetadata dataLayer) newPoolHash poolOfflineMetadata
+
+                newPoolOfflineMetadata' <- run $ (dlGetPoolMetadata dataLayer) newPoolHash
+
+                assert $ isRight newPoolOfflineMetadata
+                assert $ isRight newPoolOfflineMetadata'
+
+                assert $ newPoolOfflineMetadata == newPoolOfflineMetadata'
+
+            prop "query non-existing pool metadata" $ monadicIO $ do
+
+                (pk, _)             <- run $ createKeypair
+
+                let newPoolHash :: PoolHash
+                    newPoolHash = createPoolHash . show $ pk
+
+                ioDataMap           <- run $ newIORef stubbedInitialDataMap
+                ioBlacklistedPools  <- run $ newIORef stubbedBlacklistedPools
+
+                let dataLayer :: DataLayer
+                    dataLayer = stubbedDataLayer ioDataMap ioBlacklistedPools
+
+                newPoolOfflineMetadata <- run $ (dlGetPoolMetadata dataLayer) newPoolHash
+
+                -- This pool hash does not exist!
+                assert $ isLeft newPoolOfflineMetadata
+
+
+genSafeChar :: Gen Char
+genSafeChar = elements ['a'..'z']
+
+genSafeText :: Gen Text
+genSafeText = toS <$> listOf genSafeChar
+
+instance Arbitrary PoolOfflineMetadata where
+    arbitrary = do
+        poolName        <- PoolName         <$> genSafeText
+        poolDescription <- PoolDescription  <$> genSafeText
+        poolTicker      <- PoolTicker       <$> genSafeText
+        poolHomepage    <- PoolHomepage     <$> genSafeText
+
+        return $ createPoolOfflineMetadata
+            poolName
+            poolDescription
+            poolTicker
+            poolHomepage
+

test/Spec.hs

@@ -1,2 +1,15 @@
+module Main where
+
+import           Cardano.Prelude
+
+import           Test.Hspec (describe, hspec)
+
+import           SmashSpec (smashSpec)
+
+-- | Entry point for tests.
 main :: IO ()
-main = putStrLn "Test suite not yet implemented"
+main = hspec $ do
+    describe "SMASH tests" smashSpec
+
+
+