module Network.Discord.Framework where
import Data.Proxy
import Control.Applicative
import Control.Concurrent
import System.IO.Unsafe (unsafePerformIO)
import Network.Discord.Rest
import Network.Discord.Gateway
import Network.Discord.Types
import Control.Monad.Reader
import Data.Hashable
import Network.WebSockets (Connection)
newtype DiscordApp m a = DiscordApp
{ runEvent :: DiscordAuth m => Connection -> Event -> m a }
instance Alternative (DiscordApp m) where
empty = DiscordApp $ \_ _ -> empty
DiscordApp f <|> DiscordApp g = DiscordApp (\c e -> f c e <|> g c e)
instance Applicative (DiscordApp m) where
pure a = DiscordApp (\_ _ -> return a)
DiscordApp f <*> DiscordApp a =
DiscordApp (\c e -> f c e <*> a c e)
instance DiscordAuth (DiscordApp m) where
auth = DiscordApp $ \_ _ -> auth
version = DiscordApp $ \_ _ -> version
runIO = fail "DiscordApp cannot be lifted to IO"
rateLimits :: Vault (DiscordApp m) [(Int, Int)]
rateLimits = unsafePerformIO $ newMVar []
delete :: Eq a => [(a, b)] -> a -> [(a, b)]
delete ((a, b):xs) a'
| a == a' = delete xs a'
| otherwise = (a, b):delete xs a'
delete [] _ = []
modify :: Eq a => a -> b -> [(a, b)] -> [(a, b)]
modify a' b' ((a, b):xs)
| a == a' = (a', b'): delete xs a
| otherwise = (a, b): modify a' b' xs
modify a' b' [] = [(a', b')]
instance DiscordAuth m => DiscordRest (DiscordApp m) where
getRateLimit f = lookup' (hash f) =<< get rateLimits
where
lookup' :: (Eq a, Monad m) => a -> [(a, b)] -> m (Maybe b)
lookup' a' ((a, b):xs)
| a' == a = return (Just b)
| otherwise = lookup' a' xs
lookup' _ [] = return Nothing
setRateLimit f l = put rateLimits =<< modify (hash f) l `fmap` get rateLimits
instance DiscordAuth m => DiscordGate (DiscordApp m) where
type Vault (DiscordApp m) = MVar
data VaultKey (DiscordApp m) a = Store (MVar a)
get = liftIO . readMVar
put s v = liftIO $ do
_ <- tryTakeMVar s
putMVar s v
sequenceKey = Store $ unsafePerformIO newEmptyMVar
storeFor (Store var) = return var
connection = DiscordApp $ \c _ -> pure c
feed m event = do
liftIO $ print "Running event handler"
c <- connection
_ <- liftIO . runIO $ runEvent m c event
liftIO $ print "Returning from handler"
run m conn =
runIO $ (runEvent $ eventStream Create m) conn Nil
fork m = do
c <- connection
_ <- DiscordApp $ \_ e -> liftIO . forkIO . runIO $ runEvent m c e
return ()
instance Functor (DiscordApp m) where
f `fmap` DiscordApp a = DiscordApp (\c e -> f `fmap` a c e)
instance Monad (DiscordApp m) where
m >>= k = DiscordApp $ \c e -> do
a <- runEvent m c e
runEvent (k a) c e
instance MonadIO (DiscordApp m) where
liftIO f = DiscordApp (\_ _ -> liftIO f)
instance MonadPlus (DiscordApp m)
class DiscordRest m => EventMap f m where
type Domain f
type Codomain f
mapEvent :: Proxy f -> Domain f -> m (Codomain f)
data a :> b
data a :<>: b
instance (DiscordRest m, EventMap f m, EventMap g m, Codomain f ~ Domain g)
=> EventMap (f :> g) m where
type Domain (f :> g) = Domain f
type Codomain (f :> g) = Codomain g
mapEvent p event = mapEvent b =<< mapEvent a event
where
(a, b) = split p
split :: Proxy (a :> b) -> (Proxy a, Proxy b)
split _ = (Proxy, Proxy)
instance (DiscordRest m, EventMap f m, EventMap g m
, Domain f ~ Domain g, Codomain f ~ Codomain g)
=> EventMap (f :<>: g) m where
type Domain (f :<>: g) = Domain f
type Codomain (f :<>: g) = Codomain f
mapEvent p event = mapEvent a event <|> mapEvent b event
where
(a, b) = split p
split :: Proxy (a :<>: b) -> (Proxy a, Proxy b)
split _ = (Proxy, Proxy)