feat: initial commit

.gitignore

@@ -0,0 +1,13 @@
+/bower_components/
+/node_modules/
+/.pulp-cache/
+/output/
+/generated-docs/
+/.psc-package/
+/.psc*
+/.purs*
+/.psa*
+/.spago
+.log
+.purs-repl
+.env

.prettierrc.cjs

@@ -0,0 +1,8 @@
+module.exports = {
+  tabWidth: 2,
+  trailingComma: 'all',
+  singleQuote: true,
+  semi: false,
+  arrowParens: 'avoid',
+  plugins: [],
+}

.tool-versions

@@ -0,0 +1,3 @@
+bun 1.0.3
+purescript 0.15.12
+nodejs 20.8.0

bun/fmt.js

@@ -0,0 +1,28 @@
+/** @type {(parser: string, ps: string[]) => import("bun").Subprocess} */
+const prettier = (parser, ps) =>
+  Bun.spawn(['bun', 'x', 'prettier', '--write', '--parser', parser, ...ps], {
+    stdout: 'inherit',
+    stderr: 'inherit',
+  })
+
+const procs = [
+  prettier('babel', ['./src/**/*.js', './bun/**/*.js', './.prettierrc.cjs']),
+  prettier('json', ['./package.json', './jsconfig.json']),
+  prettier('sh', ['./Dockerfile']),
+  Bun.spawn(
+    [
+      'bun',
+      'x',
+      'purs-tidy',
+      'format-in-place',
+      'src/**/*.purs',
+      'test/**/*.purs',
+    ],
+    {
+      stdout: 'inherit',
+      stderr: 'inherit',
+    },
+  ),
+]
+
+await Promise.all(procs.map(p => p.exited))

jsconfig.json

@@ -0,0 +1,16 @@
+{
+  "compilerOptions": {
+    "types": ["bun-types"],
+    "lib": ["esnext"],
+    "target": "esnext",
+    "module": "esnext",
+    "moduleResolution": "bundler",
+    "moduleDetection": "force",
+    "jsx": "react",
+    "allowJs": true,
+    "checkJs": true,
+    "noEmit": true,
+    "strict": true
+  },
+  "include": ["tmp.js", "src/**/*.js", "bun/**/*.js"]
+}

package.json

@@ -0,0 +1,18 @@
+{
+  "name": "@ts/scraper",
+  "private": true,
+  "module": "index.js",
+  "type": "module",
+  "scripts": {
+    "fmt": "bun bun/fmt.js"
+  },
+  "devDependencies": {
+    "bun-types": "latest",
+    "purs-tidy": "^0.10.0",
+    "spago": "next"
+  },
+  "peerDependencies": {
+    "typescript": "^5.0.0"
+  },
+  "dependencies": {}
+}

spago.yaml

@@ -0,0 +1,15 @@
+package:
+  dependencies:
+    - aff
+    - arrays
+    - avar
+    - console
+  name: sync
+  test:
+    main: Test.Main
+    dependencies:
+      - spec
+workspace:
+  package_set:
+    url: https://raw.githubusercontent.com/purescript/package-sets/psc-0.15.10-20230930/packages.json
+    hash: sha256-nTsd44o7/hrTdk0c6dh0wyBqhFFDJJIeKdQU6L1zv/A=

src/Control.Monad.Async.State.purs

@@ -0,0 +1,112 @@
+module Control.Monad.State.Async where
+
+import Prelude
+
+import Control.Alt (class Alt)
+import Control.Alternative (class Alternative, class Plus)
+import Control.Monad.Error.Class (class MonadError, class MonadThrow, liftEither, try)
+import Control.Monad.Fork.Class (class MonadBracket, class MonadFork, class MonadKill, bracket, kill, never, uninterruptible)
+import Control.Monad.Reader (class MonadAsk, ReaderT(..), ask)
+import Control.Monad.Trans.Class (class MonadTrans, lift)
+import Control.Parallel (class Parallel, parallel, sequential)
+import Data.Async.Class (class AsyncState)
+import Data.Async.Class as State
+import Data.Async.Mutex (Mutex(..))
+import Data.Async.RwLock (RwLock(..))
+import Data.Maybe (Maybe)
+import Data.Newtype (class Newtype, unwrap, wrap)
+import Data.Traversable (for, for_)
+import Data.Tuple (fst, snd)
+import Data.Tuple.Nested (type (/\), (/\))
+import Effect.Aff.Class (class MonadAff)
+import Effect.Class (class MonadEffect)
+
+-- | A monadic context with some mutable state `s`
+-- | that is in a concurrency-safe `AsyncState` wrapper `w`
+-- |
+-- | Supports the following operations:
+-- | - `asyncTryRead` - Read the state as it is now, returning `Nothing` if the resource is currently locked
+-- | - `asyncRead` - Read the state, blocking if the resource is locked
+-- | - `asyncWrite` - Map the state's value, blocking if the resource is locked
+-- | - `ask` - Direct access to the low-level `AsyncState`
+class MonadAsyncState :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Type -> (Type -> Type) -> ((Type -> Type) -> Type -> Type) -> Constraint
+class (MonadTrans t, MonadAff (t m), MonadAff m, AsyncState w wwl wrl, MonadAsk (w s) (t m)) <= MonadAsyncState w wwl wrl s m t | w -> wwl, w -> wrl, m -> w, m -> s, t -> m
+
+asyncTryRead :: forall w wl rl s m t. MonadAsyncState w wl rl s m t => t m (Maybe s)
+asyncTryRead = do
+  state <- ask
+  readLock :: Maybe (rl s) <- State.tryLock state
+  snap <- for readLock (State.read state)
+  for_ readLock (State.unlock state)
+  pure snap
+
+asyncWrite :: forall w wl rl s m t a e. MonadError e (t m) => MonadAsyncState w wl rl s m t => (s -> m (a /\ s)) -> t m a
+asyncWrite f = do
+  state <- ask
+  lock :: wl s <- State.lock state
+  s <- State.read state lock
+  e <- try $ lift $ f s
+  for_ e (State.write state lock <<< snd)
+  State.unlock state lock
+  fst <$> liftEither e
+
+asyncModify :: forall w wl rl s m t e. MonadError e (t m) => MonadAsyncState w wl rl s m t => (s -> m s) -> t m Unit
+asyncModify f = asyncWrite (map (unit /\ _) <<< f)
+
+asyncRead :: forall w wl rl s m t a e. MonadError e (t m) => MonadAsyncState w wl rl s m t => (s -> m a) -> t m a
+asyncRead f = do
+  state <- ask
+  lock :: rl s <- State.lock state
+  s <- State.read state lock
+  e <- try $ lift $ f s
+  State.unlock state lock
+  liftEither e
+
+asyncPut :: forall w wl rl s m t e. MonadError e (t m) => MonadAsyncState w wl rl s m t => s -> t m Unit
+asyncPut = asyncWrite <<< const <<< pure <<< (unit /\ _)
+
+-- | Implementor of `MonadAsyncState` usable with any `AsyncState` structure.
+newtype AsyncStateT :: (Type -> Type) -> Type -> (Type -> Type) -> Type -> Type
+newtype AsyncStateT w s m ma = AsyncStateT (ReaderT (w s) m ma)
+
+derive instance Newtype (AsyncStateT w s m ma) _
+derive newtype instance MonadTrans (AsyncStateT w s)
+derive newtype instance (Alternative m) => Alternative (AsyncStateT w s m)
+derive newtype instance (Alt m) => Alt (AsyncStateT w s m)
+derive newtype instance (Plus m) => Plus (AsyncStateT w s m)
+derive newtype instance (Applicative m) => Applicative (AsyncStateT w s m)
+derive newtype instance (Apply m) => Apply (AsyncStateT w s m)
+derive newtype instance (Bind m) => Bind (AsyncStateT w s m)
+derive newtype instance (Functor m) => Functor (AsyncStateT w s m)
+derive newtype instance (Monad m) => Monad (AsyncStateT w s m)
+derive newtype instance (Monad m) => MonadAsk (w s) (AsyncStateT w s m)
+derive newtype instance (MonadEffect m) => MonadEffect (AsyncStateT w s m)
+derive newtype instance (MonadAff m) => MonadAff (AsyncStateT w s m)
+derive newtype instance (MonadThrow e m) => MonadThrow e (AsyncStateT w s m)
+derive newtype instance (MonadError e m) => MonadError e (AsyncStateT w s m)
+derive newtype instance (MonadFork f m) => MonadFork f (AsyncStateT w s m)
+instance (Parallel f m) => Parallel (AsyncStateT w s f) (AsyncStateT w s m) where
+  parallel a = wrap $ parallel $ unwrap a
+  sequential a = wrap $ sequential $ unwrap a
+
+instance (MonadError e m, MonadKill e f m) => MonadKill e f (AsyncStateT w s m) where
+  kill e f = wrap $ kill e f
+
+instance (MonadBracket e f m) => MonadBracket e f (AsyncStateT w s m) where
+  bracket a f c = wrap $ bracket (unwrap a) (\fa fb -> unwrap $ f fa fb) (unwrap <<< c)
+  uninterruptible a = wrap $ uninterruptible $ unwrap a
+  never = wrap never
+
+instance (AsyncState w wl rl, MonadAff m) => MonadAsyncState w wl rl s m (AsyncStateT w s)
+
+type RwLockStateT s m = AsyncStateT RwLock s m
+type MutexStateT s m = AsyncStateT Mutex s m
+
+runAsyncState :: forall w wl rl s m ma. MonadAff m => AsyncState w wl rl => s -> AsyncStateT w s m ma -> m ma
+runAsyncState s (AsyncStateT (ReaderT f)) = f =<< State.boxed s
+
+runMutexState :: forall s m ma. MonadAff m => s -> MutexStateT s m ma -> m ma
+runMutexState s (AsyncStateT (ReaderT f)) = f =<< State.boxed s
+
+runRwLockState :: forall s m ma. MonadAff m => s -> RwLockStateT s m ma -> m ma
+runRwLockState s (AsyncStateT (ReaderT f)) = f =<< State.boxed s

src/Data.Async.Class.purs

@@ -0,0 +1,57 @@
+module Data.Async.Class where
+
+import Prelude
+
+import Data.Maybe (Maybe)
+import Effect.Aff.Class (class MonadAff)
+
+-- | Acquire a lock that guarantees access to mutable state
+-- |
+-- | Care must be taken to release locks when errors are raised
+-- | to not cause deadlocks.
+-- |
+-- | Consider using a high-level structure like `AsyncStateT`,
+-- | which will automatically acquire and release locks when errors
+-- | occur.
+class AsyncStateLock :: (Type -> Type) -> (Type -> Type) -> Constraint
+class AsyncStateLock m lock | lock -> m where
+  -- | Attempt to synchronously acquire a lock, returning `Nothing`
+  -- | if a call to `lock` would have blocked.
+  tryLock :: forall async a. MonadAff async => m a -> async (Maybe (lock a))
+
+  -- | Block the current `Aff`-like computation until a lock may
+  -- | be acquired.
+  lock :: forall async a. MonadAff async => m a -> async (lock a)
+
+  -- | Release the lock, unblocking other threads.
+  -- |
+  -- | Repeated calls to `unlock` or calls to `unlock` on the wrong
+  -- | AsyncState `m` may either silently fail or raise an error.
+  -- |
+  -- | Implementations must raise an error if using a lock is attempted after
+  -- | `unlock` has been invoked.
+  unlock :: forall async a. MonadAff async => m a -> lock a -> async Unit
+
+-- | A lock type that supports writing data to the mutable state.
+-- |
+-- | Writable locks must also be Readable.
+class AsyncStateWritable :: (Type -> Type) -> (Type -> Type) -> Constraint
+class (AsyncStateReadable m lock) <= AsyncStateWritable m lock | lock -> m where
+  -- | Write a new value into `m`
+  write :: forall a async. MonadAff async => m a -> lock a -> a -> async Unit
+
+-- | A lock type that supports reading data from the mutable state
+class AsyncStateReadable :: (Type -> Type) -> (Type -> Type) -> Constraint
+class AsyncStateReadable m lock | lock -> m where
+  -- | Read the current value in `m`
+  read :: forall a async. MonadAff async => m a -> lock a -> async a
+
+-- | Mutable state that supports concurrent access.
+-- |
+-- | Implementors may use separate read & write guard types
+-- | (ex. `RwLock`) or use a single guard type for both reading
+-- | and writing (ex. `Mutex`)
+class AsyncState :: (Type -> Type) -> (Type -> Type) -> (Type -> Type) -> Constraint
+class (AsyncStateReadable m readLock, AsyncStateReadable m writeLock, AsyncStateWritable m writeLock, AsyncStateLock m writeLock, AsyncStateLock m readLock) <= AsyncState m writeLock readLock | writeLock -> m, readLock -> m, m -> readLock, m -> writeLock where
+  -- | Create an `m` with initial value `a`
+  boxed :: forall async a. MonadAff async => a -> async (m a)

src/Data.Async.Mutex.purs

@@ -0,0 +1,46 @@
+module Data.Async.Mutex (Mutex, MutexGuard) where
+
+import Prelude
+
+import Control.Monad.Error.Class (liftMaybe, throwError)
+import Data.Async.Class (class AsyncState, class AsyncStateLock, class AsyncStateReadable, class AsyncStateWritable, read)
+import Data.Maybe (isNothing)
+import Data.Traversable (for, for_, traverse)
+import Effect.Aff.AVar (AVar)
+import Effect.Aff.AVar as AVar
+import Effect.Aff.Class (liftAff)
+import Effect.Class (liftEffect)
+import Effect.Console as Console
+import Effect.Exception (error)
+
+-- | A lock guaranteeing exclusive access to
+-- | the data contained within a `Mutex`
+data MutexGuard a = MutexGuard (AVar a)
+
+-- | Mutable state guaranteeing mutually exclusive
+-- | access to the data of type `a`.
+-- |
+-- | There will be at most 1 thread with access to
+-- | the data contained in the mutex at a time.
+data Mutex a = Mutex (AVar a)
+
+instance AsyncState Mutex MutexGuard MutexGuard where
+  boxed = liftAff <<< map Mutex <<< AVar.new
+
+instance AsyncStateReadable Mutex MutexGuard where
+  read _ (MutexGuard cell) = liftAff $ liftMaybe (error "MutexGuard used after `unlock`!") =<< AVar.tryRead cell
+
+instance AsyncStateWritable Mutex MutexGuard where
+  write _ (MutexGuard cell) s = liftAff $ (const $ AVar.put s cell) =<< liftMaybe (error "MutexGuard used after `unlock`!") =<< AVar.tryTake cell
+
+instance AsyncStateLock Mutex MutexGuard where
+  unlock (Mutex stateCell) (MutexGuard localStateCell) = liftAff do
+    state <- AVar.tryTake localStateCell
+    when (isNothing state) $ throwError $ error "MutexGuard unlocked already!"
+    for_ state (flip AVar.put stateCell)
+  lock (Mutex stateCell) = liftAff do
+    state <- AVar.take stateCell
+    MutexGuard <$> AVar.new state
+  tryLock (Mutex stateCell) = liftAff do
+    state <- AVar.tryTake stateCell
+    for state (map MutexGuard <<< AVar.new)

src/Data.Async.RwLock.purs

@@ -0,0 +1,136 @@
+module Data.Async.RwLock (RwLock, ReadGuard, WriteGuard) where
+
+import Prelude
+
+import Control.Monad.Error.Class (liftMaybe, throwError)
+import Data.Array as Array
+import Data.Async.Class (class AsyncState, class AsyncStateLock, class AsyncStateReadable, class AsyncStateWritable, lock)
+import Data.Either (Either(..))
+import Data.Maybe (Maybe(..), fromMaybe)
+import Data.Newtype (class Newtype, wrap)
+import Data.Set (Set)
+import Data.Set as Set
+import Data.Traversable (for, for_)
+import Effect (Effect)
+import Effect.Aff (Aff, launchAff_, makeAff)
+import Effect.Aff.AVar (AVar)
+import Effect.Aff.AVar as AVar
+import Effect.Aff.Class (liftAff)
+import Effect.Class (liftEffect)
+import Effect.Exception (error)
+
+data ReadGuard :: Type -> Type
+data ReadGuard a = ReadGuard ReaderId a
+
+data WriteGuard :: Type -> Type
+data WriteGuard a = WriteGuard (AVar a)
+
+newtype ReaderId = ReaderId Int
+
+derive instance Newtype ReaderId _
+derive newtype instance Semiring ReaderId
+derive newtype instance Show ReaderId
+derive newtype instance Eq ReaderId
+derive newtype instance Ord ReaderId
+
+newtype ReaderCount = ReaderCount Int
+
+derive instance Newtype ReaderCount _
+
+-- | A mutable location in memory with guaranteed exclusive access to
+-- | any number of readers or a single writer
+data RwLock a = RwLock
+  { nextReaderId :: AVar ReaderId
+  , readers :: AVar (Set ReaderId)
+  , writerQueue :: AVar (Array (Effect Unit))
+  , state :: AVar a
+  }
+
+makeReadGuard :: forall a. AVar ReaderId -> AVar (Set ReaderId) -> AVar a -> a -> Aff (ReadGuard a)
+makeReadGuard nextReaderIdCell readersCell stateCell state = do
+  nextReaderId <- AVar.take nextReaderIdCell
+  ids <- AVar.take readersCell
+  AVar.put (nextReaderId + ReaderId 1) nextReaderIdCell
+  AVar.put (Set.insert nextReaderId ids) readersCell
+  AVar.put state stateCell
+  pure $ ReadGuard nextReaderId state
+
+mayWrite :: AVar (Array (Effect Unit)) -> Aff Unit
+mayWrite writerQCell = do
+  writerQueue <- AVar.take writerQCell
+  liftEffect $ for_ (Array.head writerQueue) identity
+  AVar.put (fromMaybe [] $ Array.tail writerQueue) writerQCell
+
+instance AsyncState RwLock WriteGuard ReadGuard where
+  boxed a = liftAff do
+    state <- AVar.new a
+    nextReaderId <- AVar.new $ wrap 1
+    readers <- AVar.new Set.empty
+    writerQueue <- AVar.new mempty
+    pure $ RwLock { state, nextReaderId, readers, writerQueue }
+
+instance AsyncStateWritable RwLock WriteGuard where
+  write _ (WriteGuard stateCell) s =
+    liftAff
+      $ const (AVar.put s stateCell)
+          =<< liftMaybe (error "WriteGuard used after `unlock` invoked!")
+          =<< AVar.tryTake stateCell
+
+instance AsyncStateReadable RwLock WriteGuard where
+  read _ (WriteGuard stateCell) =
+    liftAff
+      $ liftMaybe (error "WriteGuard used after `unlock` invoked!")
+          =<< AVar.tryRead stateCell
+
+instance AsyncStateReadable RwLock ReadGuard where
+  read (RwLock { readers: readersCell }) (ReadGuard id a) = liftAff do
+    readers <- AVar.read readersCell
+    when (not $ Set.member id readers) $ throwError $ error "ReadGuard used after `unlock` invoked!"
+    pure a
+
+instance AsyncStateLock RwLock ReadGuard where
+  unlock (RwLock { readers: readersCell, writerQueue: writerQCell }) (ReadGuard id _) = liftAff do
+    readers <- Set.delete id <$> AVar.take readersCell
+    AVar.put readers readersCell
+    when (readers == Set.empty) $ mayWrite writerQCell
+  tryLock (RwLock { readers: readersCell, state: stateCell, nextReaderId: nextReaderIdCell }) = liftAff do
+    stateM <- AVar.tryTake stateCell
+    for stateM $ makeReadGuard nextReaderIdCell readersCell stateCell
+  lock (RwLock { readers: readersCell, state: stateCell, nextReaderId: nextReaderIdCell }) = liftAff do
+    state <- AVar.take stateCell
+    makeReadGuard nextReaderIdCell readersCell stateCell state
+
+instance AsyncStateLock RwLock WriteGuard where
+  unlock (RwLock { writerQueue: writerQCell, state: rwLockStateCell }) (WriteGuard localStateCell) = liftAff do
+    state <- AVar.take localStateCell
+    AVar.put state rwLockStateCell
+    mayWrite writerQCell
+  tryLock (RwLock { readers: readersCell, state: stateCell }) = liftAff do
+    readers <- AVar.take readersCell
+    if readers == Set.empty then do
+      stateM <- AVar.tryTake stateCell
+      AVar.put readers readersCell
+      for stateM (map WriteGuard <<< AVar.new)
+    else do
+      AVar.put readers readersCell
+      pure Nothing
+  lock rw@(RwLock { writerQueue: writerQCell, readers: readersCell, state: stateCell }) = liftAff do
+    let
+      blockOnWritable_ cb = do
+        launchAff_ do
+          writerQ <- AVar.take writerQCell
+          AVar.put (writerQ <> [ cb $ Right unit ]) writerQCell
+          pure unit
+        pure mempty
+      blockOnWritable = makeAff blockOnWritable_
+      onWritable = do
+        state <- AVar.take stateCell
+        WriteGuard <$> AVar.new state
+    readers <- AVar.take readersCell
+    if readers == Set.empty then do
+      AVar.put readers readersCell
+      onWritable
+    else do
+      AVar.put readers readersCell
+      blockOnWritable
+      lock rw

test/Test.Main.purs

@@ -0,0 +1,60 @@
+module Test.Main where
+
+import Prelude
+
+import Control.Monad.Error.Class (try)
+import Control.Monad.State.Async (AsyncStateT, asyncModify, asyncPut, asyncRead, runAsyncState)
+import Control.Monad.Trans.Class (lift)
+import Control.Parallel (parallel, sequential)
+import Data.Async.Class (class AsyncState)
+import Data.Async.Mutex (Mutex)
+import Data.Async.RwLock (RwLock)
+import Data.Either (isLeft)
+import Data.Identity (Identity)
+import Data.Newtype (wrap)
+import Effect (Effect)
+import Effect.Aff (Aff, delay, launchAff_)
+import Test.Spec (SpecT, describe, it)
+import Test.Spec.Assertions (shouldEqual, shouldSatisfy)
+import Test.Spec.Reporter (consoleReporter)
+import Test.Spec.Runner (runSpec)
+
+common :: forall @w wl rl. AsyncState w wl rl => SpecT Aff Unit Identity Unit
+common = do
+  it "does not throw" $ runAsyncState unit (pure @(AsyncStateT w Unit Aff) unit)
+  it "supports single-threaded state manipulation" do
+    runAsyncState 0 do
+      pure @(AsyncStateT w Int Aff) unit
+      flip shouldSatisfy isLeft =<< try (asyncRead $ shouldEqual 1)
+      asyncPut 1
+      asyncRead $ shouldEqual 1
+      asyncModify $ \n -> pure $ n + 2
+      asyncRead $ shouldEqual 3
+  it "supports concurrent state manipulation" do
+    let
+      t1 = parallel do
+        lift $ delay $ wrap 50.0
+        asyncModify
+          ( \s -> do
+              delay $ wrap 100.0
+              pure $ s <> "john"
+          )
+        pure unit
+      t2 = parallel do
+        asyncPut "hello, "
+        lift $ delay $ wrap 60.0
+        asyncModify (pure <<< (_ <> "!"))
+        pure unit
+
+    runAsyncState "" do
+      pure @(AsyncStateT w String Aff) unit
+      sequential (pure (\_ _ -> unit) <*> t1 <*> t2)
+      asyncRead (shouldEqual "hello, john!")
+
+main :: Effect Unit
+main = launchAff_ $ runSpec [ consoleReporter ] do
+  describe "AsyncStateT" do
+    describe "MutexStateT" do
+      common @Mutex
+    describe "RwLockStateT" do
+      common @RwLock