RioSpec.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

module Test.Data.Registry.Make.RioSpec where

import Control.Monad.Trans.Resource
import Data.IORef
import Data.Map as M hiding (singleton)
import Data.Registry as Rio
import Protolude hiding (C1, D1)
import Test.Tasty.Extensions

test_fmap = test "a cached value can still be mapped over" $ do
  -- count the number of creation for the counter
  creations <- liftIO (newIORef (0 :: Int))

  -- create a singleton counter starting at 1
  let counter = Rio.singleton $ liftIO $ do
        c <- newIORef (1 :: Int)
        modifyIORef creations (+ 1)
        pure c

  -- make the counter once, then make the counter start at 2
  c1 <- liftIO (newIORef (2 :: Int))
  ref <- runRio (counter >> (counter $> c1))

  -- the counter starts at 2
  incremented <- liftIO . readIORef $ ref
  incremented === 2

  -- the counter has been created only once
  created <- liftIO . readIORef $ creations
  created === 1

test_singletons_with_specialization = test "some effectful components can be cached to become singletons in some contexts" $ do
  let registry =
        singletons $
          specialize @(Rio Storage3) (valTo @Rio (DatabaseConfig "localhost" 9876)) $
            funTo @Rio newApp
              <: funTo @Rio newBusinessLogic
              <: funTo @Rio Storage3
              <: funTo @Rio Storage2
              <: funTo @Rio Storage1
              <: funTo @Rio newConnectionPool
              <: fun newCounter
              <: valTo @Rio (DatabaseConfig "localhost" 5432)

  withRegistryM @App registry $ \App {..} -> do
    let db1 = getDatabaseConfig $ getStorage1ConnectionPool storage1
    let db2 = getDatabaseConfig $ getStorage2ConnectionPool storage2
    let db3 = getDatabaseConfig $ getStorage3ConnectionPool storage3

    db1 === db2
    db2 /== db3
    db3 === DatabaseConfig "localhost" 9876

    n <- readCounter counter
    n
      === [ ("create the App", 1),
            ("create the BusinessLogic", 1),
            ("http://localhost:5432", 1),
            ("http://localhost:9876", 1)
          ]

-- * HELPERS

data App = App
  { storage1 :: Storage1,
    storage2 :: Storage2,
    storage3 :: Storage3,
    businessLogic :: BusinessLogic,
    counter :: Counter
  }

newApp :: Counter -> Storage1 -> Storage2 -> Storage3 -> BusinessLogic -> Rio App
newApp counter s1 s2 s3 bl = do
  incrementCounter counter "create the App"
  pure (App s1 s2 s3 bl counter)

newtype ConnectionPool = ConnectionPool {getDatabaseConfig :: DatabaseConfig}

newConnectionPool :: Counter -> DatabaseConfig -> Rio ConnectionPool
newConnectionPool counter config = do
  let key = databaseConfigUrl config

  let create = do
        -- count the number of times that a pool is created with some specific parameters
        incrementCounter counter (databaseConfigUrl config)
        pure (ConnectionPool config)
  let destroy = const $ pure ()

  cacheAt key (snd <$> allocate create destroy)

data DatabaseConfig = DatabaseConfig {host :: Text, port :: Int} deriving (Eq, Show)

databaseConfigUrl :: DatabaseConfig -> Text
databaseConfigUrl (DatabaseConfig h p) = "http://" <> h <> ":" <> show p

newtype Storage1 = Storage1 {getStorage1ConnectionPool :: ConnectionPool}

newtype Storage2 = Storage2 {getStorage2ConnectionPool :: ConnectionPool}

newtype Storage3 = Storage3 {getStorage3ConnectionPool :: ConnectionPool}

newtype Counter = Counter (IORef (Map Text Int))

newtype BusinessLogic = BusinessLogic Storage1

newBusinessLogic :: Counter -> Storage1 -> Storage3 -> Rio BusinessLogic
newBusinessLogic counter storage1 _storage3 = do
  incrementCounter counter "create the BusinessLogic"
  pure $ BusinessLogic storage1

newCounter :: Rio Counter
newCounter = Counter <$> liftIO (newIORef mempty)

incrementCounter :: MonadIO m => Counter -> Text -> m ()
incrementCounter (Counter ref) key = liftIO $ do
  m <- readIORef ref
  let current = fromMaybe 0 (M.lookup key m)
  modifyIORef ref $ pure (M.insert key (current + 1) m)

readCounter :: MonadIO m => Counter -> m (Map Text Int)
readCounter (Counter ref) = liftIO $ readIORef ref