I'm trying to write a convenient abstraction to thottle api calls. The API calls will be some kind of HTTP request. I want to be able to write all the app logic as if I were just in the IO Monad but then have the abstraction throttle the calls for me so I don't surpass some predefined limit. Having these calls run asynchronously would be nice. Right now I have this.
data APICallStats = APICallStats
{
startTime :: !UTCTime
, requestCount :: !Int
, tps :: !Int
} deriving Show
newtype APICall a = APICall (IO a)
initStats :: Int -> IO APICallStats
initStats limit = APICallStats <$> getCurrentTime <*> pure 0 <*> pure limit
makeCall :: MVar APICallStats -> APICall a -> IO a
makeCall mv (APICall f) = do
(APICallStats st c t) <- readMVar mv
now <- getCurrentTime
let inSeconds = realToFrac (diffUTCTime now st) :: Double
cp1 = fromIntegral (c+1)
td = fromIntegral t
when (cp1 / inSeconds > td)
(threadDelay (round $ (cp1 / td - inSeconds)*1000000))
modifyMVar_ mv
(\(APICallStats start req ts) -> return $ APICallStats start (req+1) ts)
f
And I can test it like this. And it works fine in a single or multiple threads because of the MVar.
testCall :: String -> APICall ()
testCall id = APICall (getCurrentTime >>= (putStrLn . ((++) (id ++ " ")) . show))
test :: IO ()
test = do
mv <- initStats 1 >>= newMVar
forever $ makeCall mv (testCall "")
threadedTest :: IO ()
threadedTest = do
mv <- initStats 1 >>= newMVar
threadId <- forkIO $ forever $ makeCall mv (testCall "thread0")
forever $ makeCall mv (testCall "main thread")
killThread threadId
This is nice and all but it is not as abstract as I want it to be. Since there will only be a couple specific API calls I can have them return the type APICall a. And then make this a monad that is an instance of MonadIO so I can just write my logic and use liftIO when I need to. But I'm unsure if I would be able to make this a monad that didn't break the laws and how exactly to go about it.
EDIT
I think I've gotten pretty close to what I want it to do.
withThrottle :: Int -> StateT (MVar APICallStats) IO a -> IO a
withThrottle limit f = do
mv <- initStats limit >>= newMVar
evalStateT f mv
process :: APICall a -> StateT (MVar APICallStats) IO a
process a = do
mv <- get
liftIO $ makeCall mv a
With this I can write something like this.
stateTest = do
withThrottle 2 $ do
process (testCall "")
process (testCall "")
process (testCall "")
liftIO $ threadDelay 10000000 -- Some long computation
process (testCall "")
process (testCall "")
process (testCall "")
process (testCall "")
With a long running app the entire thing can run is this monad. This will guarantee that It doesn't make too many outside API calls over the lifetime of the service. I just don't want the state monad. Just something that is MonadIO. So I think I just need to hide that and I'll be done. But the solution isn't very pretty so other suggestions welcome.
Related
I'm working through Parallel and Concurrent Programming in Haskell on the Overlapping Input/Output Chapter and I can't understand how async actually works asynchronously.
data Async a = Async (MVar a)
async' :: IO a -> IO (Async a)
async' action = do
var <- newEmptyMVar
forkIO (do r <- action; putMVar var r)
return (Async var)
-- if I desugar the do notation for async:
async'' :: IO a -> IO (Async a)
async'' action = newEmptyMVar >>= \var ->
(forkIO (action >>= \r -> putMVar var r)) >>
(return $ Async var)
wait :: Async a -> IO a
wait (Async var) = readMVar var
blah = do
a1 <- async'' (getURL "http://www.wikipedia.org/wiki/Shovel")
a2 <- async'' (getURL "http://www.wikipedia.org/wiki/Spade")
r1 <- wait a1
r2 <- wait a2
print (B.length r1, B.length r2)
-- if I desguar the above do block I get this, which looks
-- like a2 won't happen until a1 is finished?
blah' = async''(getURL "http://www.wikipedia.org/wiki/Shovel") >>= \a1 ->
async''(getURL "http://www.wikipedia.org/wiki/Spade") >>= \a2 ->
wait a1 >>= \r1 ->
wait a2 >>= \r2 ->
(print (B.length r1, B.length r2))
When I run this no matter what I do, Shovel always resolves before Spade. So how is this running async? I would have expected interleaving sometimes (getting Spade before shovel). Is my exampple just too fast and I'd see this behavior if I made many more examples?
no matter what I do, Shovel always resolves before Spade.
Well, you always ask for the result of shovel before spade via that call to wait coming first. You always start shovel before spade so it isn't surprising if it almost always resolves first too.
A simple test: use threadDelay 100000 >> getURL "...shovel" then look at the network traffic. This will show you things are happening concurrently.
I'm writing some code (around card-playing strategies) that uses State and recursion together. Perhaps this part doesn't need to actually (it already feels clumsy to me, even as a relative beginner), but there are other parts that probably do so my general question stands...
My initial naive implementation is entirely deterministic (the choice of bid is simply the first option provided by the function validBids):
bidOnRound :: (DealerRules d) => d -> NumCards -> State ([Player], PlayerBids) ()
bidOnRound dealerRules cardsThisRound = do
(players, bidsSoFar) <- get
unless (List.null players) $ do
let options = validBids dealerRules cardsThisRound bidsSoFar
let newBid = List.head $ Set.toList options
let p : ps = players
put (ps, bidsSoFar ++ [(p, newBid)])
bidOnRound dealerRules cardsThisRound
And I call it from:
playGame :: (DealerRules d, ScorerRules s) => d -> s -> StateT Results IO ()
...
let (_, bidResults) = execState (bidOnRound dealerRules cardsThisRound) (NonEmpty.toList players, [])
Now I'm aware that I need to bring randomness into this and several other parts of the code. Not wanting to litter IO everywhere, nor pass round random seeds manually all the time, I feel I should be using MonadRandom or something. A library I'm using uses it to good effect. Is this a wise choice?
Here's what I tried:
bidOnRound :: (DealerRules d, RandomGen g) => d -> NumCards -> RandT g (State ([Player], PlayerBids)) ()
bidOnRound dealerRules cardsThisRound = do
(players, bidsSoFar) <- get
unless (List.null players) $ do
let options = Set.toList $ validBids dealerRules cardsThisRound bidsSoFar
rnd <- getRandomR (0 :: Int, len options - 1)
let newBid = options List.!! rnd
let p : ps = players
put (ps, bidsSoFar ++ [(p, newBid)])
bidOnRound dealerRules cardsThisRound
but I'm uncomfortable already, plus can't work out how to call this, e.g. using evalRand in combination with execState etc. The more I read on MonadRandom, RandGen and mtl vs others, the less sure I am of what I'm doing...
How should I neatly combine Randomness and State and how do I call these properly?
Thanks!
EDIT: for reference, full current source on Github.
Well how about an example to help you out. Since you didn't post a full working code snippet I'll just replace a lot of your operations and show how the monads can be evaluated:
import Control.Monad.Trans.State
import Control.Monad.Random
import System.Random.TF
bidOnRound :: (RandomGen g) => Int -> RandT g (State ([Int], Int)) ()
bidOnRound i =
do rand <- getRandomR (10,20)
s <- lift $ get
lift $ put ([], i + rand + snd s)
main :: IO ()
main =
do g <- newTFGen
print $ flip execState ([],1000) $ evalRandT (bidOnRound 100) g
The thing to note here is you "unwrap" the outer monad first. So if you have RandT (StateT Reader ...) ... then you run RandT (ex via evalRandT or similar) then the state then the reader. Secondly, you must lift from the outer monad to use operations on the inner monad. This might seem clumsy and that is because it is horribly clumsy.
The best developers I know - those whose code I enjoy looking at and working with - extract monad operations and provide an API with all the primitives complete so I don't need to think about the structure of the monad while I'm thinking about the structure of the logic I'm writing.
In this case (it will be slightly contrived since I wrote the above without any application domain, rhyme or reason) you could write:
type MyMonad a = RandT TFGen (State ([Int],Int)) a
runMyMonad :: MyMonad () -> IO Int
runMyMonad f =
do g <- newTFGen
pure $ snd $ flip execState ([],1000) $ evalRandT f g
With the Monad defined as a simple alias and execution operation the basic functions are easier:
flipCoin :: MyMonad Int
flipCoin = getRandomR (10,20)
getBaseValue :: MyMonad Int
getBaseValue = snd <$> lift get
setBaseValue :: Int -> MyMonad ()
setBaseValue v = lift $ state $ \s -> ((),(fst s, v))
With that leg-work out of the way, which is usually a minor part of making a real application, the domain specific logic is easier to write and certainly easier to read:
bidOnRound2 :: Int -> MyMonad ()
bidOnRound2 i =
do rand <- flipCoin
old <- getBaseValue
setBaseValue (i + rand + old)
main2 :: IO ()
main2 = print =<< runMyMonad (bidOnRound2 100)
EDITED 2015-11-29: see bottom
I'm trying to write an application that has a do-last-action-again button. The command in question can ask for input, and my thought for how to accomplish this was to just rerun the resulting monad with memoized IO.
There are lots of posts on SO with similar questions, but none of the solutions seem to work here.
I lifted the memoIO code from this SO answer, and changed the implementation to run over MonadIO.
-- Memoize an IO function
memoIO :: MonadIO m => m a -> m (m a)
memoIO action = do
ref <- liftIO $ newMVar Nothing
return $ do
x <- maybe action return =<< liftIO (takeMVar ref)
liftIO . putMVar ref $ Just x
return x
I've got a small repro of my app's approach, the only real difference being my app has a big transformer stack instead of just running in IO:
-- Global variable to contain the action we want to repeat
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
-- Run an action and store it as the action to repeat
repeatable :: IO String -> IO String
repeatable action = do
writeIORef actionToRepeat action
action
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
The idea being I can store an action with memoized IO in an IORef (via repeatable) when I record what was last done, and then do it again it out with doRepeat.
I test this via:
-- IO function to memoize
getName :: IO String
getName = do
putStr "name> "
getLine
main :: IO ()
main = do
repeatable $ do
memoized <- memoIO getName
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
with expected output:
name> isovector
hello isovector
hello isovector
but actual output:
name> isovector
hello isovector
name> wasnt memoized
hello wasnt memoized
I'm not entirely sure what the issue is, or even how to go about debugging this. Gun to my head, I'd assume lazy evaluation is biting me somewhere, but I can't figure out where.
Thanks in advance!
EDIT 2015-11-29: My intended use case for this is to implement the repeat last change operator in a vim-clone. Each action can perform an arbitrary number of arbitrary IO calls, and I would like it to be able to specify which ones should be memoized (reading a file, probably not. asking the user for input, yes).
the problem is in main you are creating a new memo each time you call the action
you need to move memoized <- memoIO getName up above the action
main :: IO ()
main = do
memoized <- memoIO getName --moved above repeatable $ do
repeatable $ do
--it was here
name <- memoized
putStr "hello "
putStrLn name
return name
doRepeat
return ()
edit: is this acceptable
import Data.IORef
import System.IO.Unsafe
{-# NOINLINE actionToRepeat #-}
actionToRepeat :: IORef (IO String)
actionToRepeat = unsafePerformIO . newIORef $ return ""
type Repeatable a = IO (IO a)
-- Run an action and store the Repeatable part of the action
repeatable :: Repeatable String -> IO String
repeatable action = do
repeatAction <- action
writeIORef actionToRepeat repeatAction
repeatAction
-- Run the last action stored by repeatable
doRepeat :: IO String
doRepeat = do
x <- readIORef actionToRepeat
x
-- everything before (return $ do) is run just once
hello :: Repeatable String
hello = do
putStr "name> "
name <- getLine
return $ do
putStr "hello "
putStrLn name
return name
main :: IO ()
main = do
repeatable hello
doRepeat
return ()
I came up with a solution. It requires wrapping the original monad in a new transformer which records the results of IO and injects them the next time the underlying monad is run.
Posting it here so my answer is complete.
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
import Control.Applicative (Applicative(..))
import Data.Dynamic
import Data.Maybe (fromJust)
import Control.Monad.RWS
-- | A monad transformer adding the ability to record the results
-- of IO actions and later replay them.
newtype ReplayT m a =
ReplayT { runReplayT :: RWST () [Dynamic] [Dynamic] m a }
deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadState [Dynamic]
, MonadWriter [Dynamic]
, MonadTrans
)
-- | Removes the first element from a list State and returns it.
dequeue :: MonadState [r] m
=> m (Maybe r)
dequeue = do
get >>= \case
[] -> return Nothing
(x:xs) -> do
put xs
return $ Just x
-- | Marks an IO action to be memoized after its first invocation.
sample :: ( MonadIO m
, Typeable r)
=> IO r
-> ReplayT m r
sample action = do
a <- dequeue >>= \case
Just x -> return . fromJust $ fromDynamic x
Nothing -> liftIO action
tell [toDyn a]
return a
-- | Runs an action and records all of its sampled IO. Returns a
-- action which when invoked will use the recorded IO.
record :: Monad m
=> ReplayT m a
-> m (m a)
record action = do
(a, w) <- evalRWST (runReplayT action) () []
return $ do
evalRWST (runReplayT action) () w
return a
I have a timer function that takes a time to wait for and a starting time and returns the current UTCTime when it ends:
runTimer :: NominalDiffTime -> UTCTime -> IO UTCTime
I'd like to run this timer function in a separate thread, because I want to simultaneously be able to capture input from the user. In this main loop I also use a WriterT monad transformer to log events. I also want to log an event when the timer ends normally, so I've tried using forkFinally:
type Log = [Entry]
data Entry = Entry {
_etype :: EntryType
, _etime :: UTCTime
} deriving Show
data EntryType = Start | End | Pause | Quit deriving Show
type Program = WriterT Log IO
loop :: Maybe ThreadId -> Program ()
loop timerId = do
liftIO $ putStr ">"
x <- liftIO $ getChar
now <- liftIO $ getCurrentTime
case x of
'q' -> do
liftIO $ putStrLn "\n Quitting..."
tell [Entry Quit now]
-- Kill the timer thread if there is one.
maybe (return ()) (liftIO . killThread) timerId
liftIO $ putStrLn "\n Quit."
's' -> case timerId of
Just _ -> do
liftIO $ putStrLn "Timer already started!"
loop timerId
Nothing -> do
-- Start a timer in a new thread.
tell [Entry Start now]
timerId' <- liftIO $ forkFinally (runTimer 5 now) eHandler
-- Call the main loop with the timer thread id.
loop (Just timerId')
_ -> do
liftIO $ putChar x
loop timerId
eHandler :: (Show a, Exception e) => Either e a -> IO ()
eHandler (Left x) = throw x
eHandler (Right x) = do
putStrLn $ show x
eHandler' :: (Exception t) => Either t UTCTime -> WriterT Log IO ()
eHandler' (Left x) = throw x
eHandler' (Right t) = do
tell [Entry End t]
This code works when using forkFinally with eHandler. But how can I get it to work with eHandler', so that I can log when the timer finishes?
You need to convert a WriterT monad to an IO monad, something like this:
wrapWriterT::WriterT a IO c->IO c
wrapWriterT writer = do
(result, log) <- runWriterT writer
<do something with the log, like send it to a file>
return result
and then use it like this:
timerId' <- liftIO $ forkFinally (runTimer 5 now) (wrapWriterT . eHandler')
What is happening here? Remember, the Writer monad is used to pass an extra string around, that can be appended to, like a log. The IO monad is used for, well.... IO. forkFinally needs type IO(), but the WriterT is for both IO and also returns a log. forkFinally doesn't know what to do with this log, but if you wrap it in a function to extract the log and do something with it, then you are left with simply an IO monad, which forkFinally knows how to handle.
I do want to ask though.... The standard timer functions in Control.Concurrent are nonblocking (you hand it a function of type IO(), and it returns, with the understanding that it will be done later). What are you doing that needs explicit threads?
The current version of the Pipes tutorial, uses the following two functions in one of the example:
stdout :: () -> Consumer String IO r
stdout () = forever $ do
str <- request ()
lift $ putStrLn str
stdin :: () -> Producer String IO ()
stdin () = loop
where
loop = do
eof <- lift $ IO.hIsEOF IO.stdin
unless eof $ do
str <- lift getLine
respond str
loop
As is mentinoed in the tutorial itself, P.stdin is a bit more complicated due to the need to check for the end of input.
Are there any nice ways to rewrite P.stdin to not need a manual tail recursive loop and use higher order control flow combinators like P.stdout does? In an imperative language I would use a structured while loop or a break statement to do the same thing:
while(not IO.isEOF(IO.stdin) ){
str <- getLine()
respond(str)
}
forever(){
if(IO.isEOF(IO.stdin) ){ break }
str <- getLine()
respond(str)
}
I prefer the following:
import Control.Monad
import Control.Monad.Trans.Either
loop :: (Monad m) => EitherT e m a -> m e
loop = liftM (either id id) . runEitherT . forever
-- I'd prefer 'break', but that's in the Prelude
quit :: (Monad m) => e -> EitherT e m r
quit = left
You use it like this:
import Pipes
import qualified System.IO as IO
stdin :: () -> Producer String IO ()
stdin () = loop $ do
eof <- lift $ lift $ IO.hIsEOF IO.stdin
if eof
then quit ()
else do
str <- lift $ lift getLine
lift $ respond str
See this blog post where I explain this technique.
The only reason I don't use that in the tutorial is that I consider it less beginner-friendly.
Looks like a job for whileM_:
stdin () = whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) (lift getLine >>= respond)
or, using do-notation similarly to the original example:
stdin () =
whileM_ (lift . fmap not $ IO.hIsEOF IO.stdin) $ do
str <- lift getLine
respond str
The monad-loops package offers also whileM which returns a list of intermediate results instead of ignoring the results of the repeated action, and other useful combinators.
Since there is no implicit flow there is no such thing like "break". Moreover your sample already is small block which will be used in more complicated code.
If you want to stop "producing strings" it should be supported by your abstraction. I.e. some "managment" of "pipes" using special monad in Consumer and/or other monads that related with this one.
You can simply import System.Exit, and use exitWith ExitSuccess
Eg. if (input == 'q')
then exitWith ExitSuccess
else print 5 (anything)