diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Change log + +## 0.1.0.0 + +Initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,23 @@ +[The MIT License (MIT)][] + +Copyright (c) 2020 Jason Shipman + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + +[The MIT License (MIT)]: https://opensource.org/licenses/MIT diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,14 @@ +# [context-resource][] + +[![Version badge][]][version] + +🚧 This README is under construction and could use some love. 🚧 + +`context-resource` contains a thread-safe, pool-compatible resource provider +abstraction that supports resource-sharing within nested actions. + +See the Haddocks for more info on the library. + +[context-resource]: https://github.com/jship/context +[Version badge]: https://img.shields.io/hackage/v/context-resource?color=brightgreen&label=version&logo=haskell +[version]: https://hackage.haskell.org/package/context-resource diff --git a/context-resource.cabal b/context-resource.cabal new file mode 100644 --- /dev/null +++ b/context-resource.cabal @@ -0,0 +1,64 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 25e9584bac69d5f10c59d16e951839e19321a6ec9958b9edf594a1256b310ff9 + +name: context-resource +version: 0.1.0.0 +synopsis: Thread-safe, pool-compatible resource provider +description: A thread-safe, pool-compatible resource provider abstraction that supports + resource-sharing within nested actions. +category: Data +homepage: https://github.com/jship/context#readme +bug-reports: https://github.com/jship/context/issues +author: Jason Shipman +maintainer: Jason Shipman +copyright: 2020 (c) Jason Shipman +license: MIT +license-file: LICENSE.md +build-type: Simple +extra-source-files: + CHANGELOG.md + LICENSE.md + package.yaml + README.md + +source-repository head + type: git + location: https://github.com/jship/context + subdir: context-resource + +library + exposed-modules: + Context.Resource + other-modules: + Paths_context_resource + hs-source-dirs: + library + ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints + build-depends: + base >=4.12 && <5 + , context >=0.1.0.0 && <0.2 + default-language: Haskell2010 + +test-suite context-resource-test-suite + type: exitcode-stdio-1.0 + main-is: Driver.hs + other-modules: + Test.Context.ResourceSpec + Paths_context_resource + hs-source-dirs: + test-suite + ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + async + , base + , context + , context-resource + , hspec + default-language: Haskell2010 diff --git a/library/Context/Resource.hs b/library/Context/Resource.hs new file mode 100644 --- /dev/null +++ b/library/Context/Resource.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RankNTypes #-} + +module Context.Resource + ( -- * Introduction + -- $intro + + -- * Provider + Provider + , withProvider + + -- * Core operations + , withResource + , shareResource + + -- * Convenience + , withSharedResource + ) where + +import Prelude +import qualified Context + +-- | An opaque resource provider. +-- +-- @since 0.1.0.0 +newtype Provider res = Provider + { store :: Context.Store (WithRes res) + } + +newtype WithRes res = WithRes (forall r. (res -> IO r) -> IO r) + +-- | Given a @with@-style function to acquire a resource, supplies the caller +-- with a resource 'Provider'. This 'Provider' should ideally be long-lived and +-- threaded throughout the application to the components that need to acquire +-- resources. +-- +-- @since 0.1.0.0 +withProvider + :: (forall r. (res -> IO r) -> IO r) + -> (Provider res -> IO a) + -> IO a +withProvider withRes f = do + Context.withStore Context.noPropagation (Just (WithRes withRes)) \store -> do + f Provider { store } + +-- | Acquire a resource from the specified 'Provider', for the duration of the +-- specified action. +-- +-- @since 0.1.0.0 +withResource :: Provider res -> (res -> IO a) -> IO a +withResource Provider { store } f = do + WithRes withRes <- Context.mine store + withRes f + +-- | Tell the specified 'Provider' to share the specified resource for the +-- duration of the specified action. All calls to 'withResource' (or +-- 'withSharedResource') within the action will return the shared resource. +-- +-- @since 0.1.0.0 +shareResource :: Provider res -> res -> IO a -> IO a +shareResource Provider { store } resource action = do + Context.use store (WithRes ($ resource)) action + +-- | Acquire a resource from the specified 'Provider' and share that resource +-- for the duration of the specified action. All calls to 'withResource' (or +-- 'withSharedResource') within the action will return the shared resource. +-- +-- This is a convenience function combining 'withResource' and 'shareResource'. +-- +-- @since 0.1.0.0 +withSharedResource :: Provider res -> (res -> IO a) -> IO a +withSharedResource provider f = do + withResource provider \resource -> do + shareResource provider resource do + f resource + +-- $intro +-- +-- This module provides a thread-safe, pool-compatible resource provider +-- abstraction that supports resource-sharing within nested actions. While it +-- was designed with resource pools in mind, the interface supports any +-- @with@-style means of acquiring a resource. +-- +-- 'withResource' can be used to acquire a resource from the provider, and +-- 'shareResource' can be used to share a particular resource for the duration +-- of an action. Subsequent calls to 'shareResource' in that action are +-- idempotent. Note that if a resource-shared action spins up new threads, the +-- shared resource will /not/ be shared implicitly across thread boundaries. +-- +-- While 'shareResource' offers the most control over resource-sharing, +-- 'withSharedResource' can be used as a convenience in the relatively common +-- case where a resource is acquired and then immediately shared within an +-- inner action. diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -0,0 +1,44 @@ +name: context-resource +version: '0.1.0.0' +github: "jship/context/context-resource" +license: MIT +license-file: LICENSE.md +copyright: 2020 (c) Jason Shipman +author: "Jason Shipman" +maintainer: "Jason Shipman" +synopsis: Thread-safe, pool-compatible resource provider +description: | + A thread-safe, pool-compatible resource provider abstraction that supports + resource-sharing within nested actions. +category: Data + +extra-source-files: +- CHANGELOG.md +- LICENSE.md +- package.yaml +- README.md + +ghc-options: + - -Wall + - -fwarn-tabs + - -Wincomplete-uni-patterns + - -Wredundant-constraints + +library: + dependencies: + - base >=4.12 && <5 + - context >=0.1.0.0 && <0.2 + source-dirs: library + +tests: + context-resource-test-suite: + source-dirs: test-suite + main: Driver.hs + build-tools: + - hspec-discover + dependencies: + - async + - base + - context + - context-resource + - hspec diff --git a/test-suite/Driver.hs b/test-suite/Driver.hs new file mode 100644 --- /dev/null +++ b/test-suite/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-suite/Test/Context/ResourceSpec.hs b/test-suite/Test/Context/ResourceSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/Context/ResourceSpec.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Test.Context.ResourceSpec + ( spec + ) where + +import Context.Resource (shareResource, withProvider, withResource, withSharedResource) +import Foreign (Ptr) +import Prelude +import Test.Hspec +import qualified Context +import qualified Control.Concurrent.Async as Async +import qualified Control.Monad as Monad +import qualified Foreign + +spec :: Spec +spec = do + describe "withResource" do + it "concurrent test" do + Async.forConcurrently_ [1 :: Int ..10] $ const do + withProvider withRes \provider -> do + withResource provider \ptr1 -> do + withResource provider \ptr2 -> do + ptr1 `shouldNotBe` ptr2 + + describe "shareResource" do + it "concurrent test" do + Async.forConcurrently_ [1 :: Int ..10] $ const do + withProvider withRes \provider -> do + withResource provider \ptr1 -> do + shareResource provider ptr1 do + withResource provider \ptr2 -> do + ptr1 `shouldBe` ptr2 + withResource provider \ptr3 -> do + ptr2 `shouldBe` ptr3 + withResource provider \ptr4 -> do + ptr1 `shouldNotBe` ptr4 + it "cannot implicitly share across thread boundaries" do + withProvider withRes \provider -> do + withResource provider \parentThread'sPtr1 -> do + shareResource provider parentThread'sPtr1 do + withResource provider \parentThread'sPtr2 -> do + parentThread'sPtr1 `shouldBe` parentThread'sPtr2 + threadDone <- Context.newEmptyMVar + Monad.void $ Context.forkIO do + withResource provider \childThread'sPtr1 -> do + parentThread'sPtr1 `shouldNotBe` childThread'sPtr1 + Context.putMVar threadDone () + Context.takeMVar threadDone + withResource provider \parentThread'sPtr3 -> do + parentThread'sPtr1 `shouldNotBe` parentThread'sPtr3 + + describe "withSharedResource" do + it "concurrent test" do + Async.forConcurrently_ [1 :: Int ..10] $ const do + withProvider withRes \provider -> do + withSharedResource provider \ptr1 -> do + withResource provider \ptr2 -> do + ptr1 `shouldBe` ptr2 + shareResource provider ptr2 do + withResource provider \ptr3 -> do + ptr2 `shouldBe` ptr3 + withResource provider \ptr4 -> do + ptr1 `shouldBe` ptr4 + it "cannot implicitly share across thread boundaries" do + withProvider withRes \provider -> do + withSharedResource provider \parentThread'sPtr1 -> do + withResource provider \parentThread'sPtr2 -> do + parentThread'sPtr1 `shouldBe` parentThread'sPtr2 + threadDone <- Context.newEmptyMVar + Monad.void $ Context.forkIO do + withResource provider \childThread'sPtr1 -> do + parentThread'sPtr1 `shouldNotBe` childThread'sPtr1 + Context.putMVar threadDone () + Context.takeMVar threadDone + withResource provider \parentThread'sPtr3 -> do + parentThread'sPtr1 `shouldBe` parentThread'sPtr3 + +withRes :: (Ptr Int -> IO a) -> IO a +withRes = Foreign.withArray [1..3]