{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Lambdabot.State
(
MonadLBState(..)
, readMS
, writeMS
, modifyMS
, GlobalPrivate
, mkGlobalPrivate
, withPS
, readPS
, writePS
, withGS
, readGS
, writeGS
, readGlobalState
, writeGlobalState
) where
import Lambdabot.File
import Lambdabot.Logging
import Lambdabot.Monad
import Lambdabot.Module
import Lambdabot.Nick
import Lambdabot.Command
import Lambdabot.Util
import Lambdabot.Util.Serial
import Control.Concurrent.Lifted
import Control.Exception.Lifted as E
import Control.Monad.Reader
import Control.Monad.Trans.Control
import qualified Data.ByteString.Char8 as P
import Data.IORef.Lifted
withMWriter :: MonadBaseControl IO m => MVar a -> (a -> (a -> m ()) -> m b) -> m b
withMWriter :: forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> (a -> m ()) -> m b) -> m b
withMWriter MVar a
mvar a -> (a -> m ()) -> m b
f = forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket
(do a
x <- forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
takeMVar MVar a
mvar; IORef a
ref <- forall (m :: * -> *) a. MonadBase IO m => a -> m (IORef a)
newIORef a
x; forall (m :: * -> *) a. Monad m => a -> m a
return (a
x,IORef a
ref))
(\(a
_,IORef a
ref) -> forall (m :: * -> *) a. MonadBase IO m => MVar a -> a -> m Bool
tryPutMVar MVar a
mvar forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadBase IO m => IORef a -> m a
readIORef IORef a
ref)
(\(a
x,IORef a
ref) -> a -> (a -> m ()) -> m b
f a
x forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadBase IO m => IORef a -> a -> m ()
writeIORef IORef a
ref)
class MonadLB m => MonadLBState m where
type LBState m
withMS :: (LBState m -> (LBState m -> m ()) -> m a) -> m a
instance MonadLB m => MonadLBState (ModuleT st m) where
type LBState (ModuleT st m) = st
withMS :: forall a.
(LBState (ModuleT st m)
-> (LBState (ModuleT st m) -> ModuleT st m ()) -> ModuleT st m a)
-> ModuleT st m a
withMS LBState (ModuleT st m)
-> (LBState (ModuleT st m) -> ModuleT st m ()) -> ModuleT st m a
f = do
MVar st
ref <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> MVar st
moduleState
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> (a -> m ()) -> m b) -> m b
withMWriter MVar st
ref LBState (ModuleT st m)
-> (LBState (ModuleT st m) -> ModuleT st m ()) -> ModuleT st m a
f
instance MonadLBState m => MonadLBState (Cmd m) where
type LBState (Cmd m) = LBState m
withMS :: forall a.
(LBState (Cmd m) -> (LBState (Cmd m) -> Cmd m ()) -> Cmd m a)
-> Cmd m a
withMS LBState (Cmd m) -> (LBState (Cmd m) -> Cmd m ()) -> Cmd m a
f = do
(a, [String])
x <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
(Run t -> m a) -> t m a
liftWith forall a b. (a -> b) -> a -> b
$ \Run Cmd
run ->
forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState m
st LBState m -> m ()
wr ->
Run Cmd
run (LBState (Cmd m) -> (LBState (Cmd m) -> Cmd m ()) -> Cmd m a
f LBState m
st (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. LBState m -> m ()
wr))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTransControl t, Monad m) =>
m (StT t a) -> t m a
restoreT (forall (m :: * -> *) a. Monad m => a -> m a
return (a, [String])
x)
readMS :: MonadLBState m => m (LBState m)
readMS :: forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS = forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS (\LBState m
st LBState m -> m ()
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return LBState m
st)
modifyMS :: MonadLBState m => (LBState m -> LBState m) -> m ()
modifyMS :: forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS LBState m -> LBState m
f = forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState m
st LBState m -> m ()
wr -> LBState m -> m ()
wr (LBState m -> LBState m
f LBState m
st)
writeMS :: MonadLBState m => LBState m -> m ()
writeMS :: forall (m :: * -> *). MonadLBState m => LBState m -> m ()
writeMS = forall (m :: * -> *).
MonadLBState m =>
(LBState m -> LBState m) -> m ()
modifyMS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
data GlobalPrivate g p = GP {
forall g p. GlobalPrivate g p -> g
global :: !g,
forall g p. GlobalPrivate g p -> [(Nick, MVar (Maybe p))]
private :: ![(Nick,MVar (Maybe p))],
forall g p. GlobalPrivate g p -> Int
maxSize :: Int
}
mkGlobalPrivate :: Int -> g -> GlobalPrivate g p
mkGlobalPrivate :: forall g p. Int -> g -> GlobalPrivate g p
mkGlobalPrivate Int
ms g
g = GP {
global :: g
global = g
g,
private :: [(Nick, MVar (Maybe p))]
private = [],
maxSize :: Int
maxSize = Int
ms
}
withPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> Nick
-> (Maybe p -> (Maybe p -> LB ()) -> LB a)
-> m a
withPS :: forall (m :: * -> *) g p a.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> (Maybe p -> (Maybe p -> LB ()) -> LB a) -> m a
withPS Nick
who Maybe p -> (Maybe p -> LB ()) -> LB a
f = do
MVar (Maybe p)
mvar <- forall (m :: * -> *) g p a.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
(MVar (Maybe p) -> m a)
-> (m (MVar (Maybe p)) -> m a) -> Nick -> m a
accessPS forall (m :: * -> *) a. Monad m => a -> m a
return forall a. a -> a
id Nick
who
forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadBaseControl IO m =>
MVar a -> (a -> (a -> m ()) -> m b) -> m b
withMWriter MVar (Maybe p)
mvar Maybe p -> (Maybe p -> LB ()) -> LB a
f
readPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> Nick -> m (Maybe p)
readPS :: forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> m (Maybe p)
readPS = forall (m :: * -> *) g p a.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
(MVar (Maybe p) -> m a)
-> (m (MVar (Maybe p)) -> m a) -> Nick -> m a
accessPS (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar) (\m (MVar (Maybe p))
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
accessPS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> (MVar (Maybe p) -> m a) -> (m (MVar (Maybe p)) -> m a)
-> Nick
-> m a
accessPS :: forall (m :: * -> *) g p a.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
(MVar (Maybe p) -> m a)
-> (m (MVar (Maybe p)) -> m a) -> Nick -> m a
accessPS MVar (Maybe p) -> m a
success m (MVar (Maybe p)) -> m a
failure Nick
who = forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState m
state LBState m -> m ()
writer ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Nick
who forall a b. (a -> b) -> a -> b
$ forall g p. GlobalPrivate g p -> [(Nick, MVar (Maybe p))]
private LBState m
state of
Just MVar (Maybe p)
mvar -> do
let newPrivate :: [(Nick, MVar (Maybe p))]
newPrivate = (Nick
who,MVar (Maybe p)
mvar)forall a. a -> [a] -> [a]
:
forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
/=Nick
who) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall g p. GlobalPrivate g p -> [(Nick, MVar (Maybe p))]
private LBState m
state)
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Nick, MVar (Maybe p))]
newPrivate seq :: forall a b. a -> b -> b
`seq` LBState m -> m ()
writer (LBState m
state { private :: [(Nick, MVar (Maybe p))]
private = [(Nick, MVar (Maybe p))]
newPrivate })
MVar (Maybe p) -> m a
success MVar (Maybe p)
mvar
Maybe (MVar (Maybe p))
Nothing -> m (MVar (Maybe p)) -> m a
failure forall a b. (a -> b) -> a -> b
$ do
MVar (Maybe p)
mvar <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadBase IO m => a -> m (MVar a)
newMVar forall a. Maybe a
Nothing
let newPrivate :: [(Nick, MVar (Maybe p))]
newPrivate = forall a. Int -> [a] -> [a]
take (forall g p. GlobalPrivate g p -> Int
maxSize LBState m
state) forall a b. (a -> b) -> a -> b
$ (Nick
who,MVar (Maybe p)
mvar)forall a. a -> [a] -> [a]
: forall g p. GlobalPrivate g p -> [(Nick, MVar (Maybe p))]
private LBState m
state
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Nick, MVar (Maybe p))]
newPrivate seq :: forall a b. a -> b -> b
`seq` LBState m -> m ()
writer (LBState m
state { private :: [(Nick, MVar (Maybe p))]
private = [(Nick, MVar (Maybe p))]
newPrivate })
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Maybe p)
mvar
withGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> (g -> (g -> m ()) -> m ()) -> m ()
withGS :: forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
(g -> (g -> m ()) -> m ()) -> m ()
withGS g -> (g -> m ()) -> m ()
f = forall (m :: * -> *) a.
MonadLBState m =>
(LBState m -> (LBState m -> m ()) -> m a) -> m a
withMS forall a b. (a -> b) -> a -> b
$ \LBState m
state LBState m -> m ()
writer ->
g -> (g -> m ()) -> m ()
f (forall g p. GlobalPrivate g p -> g
global LBState m
state) forall a b. (a -> b) -> a -> b
$ \g
g -> LBState m -> m ()
writer forall a b. (a -> b) -> a -> b
$ LBState m
state { global :: g
global = g
g }
readGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> m g
readGS :: forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
m g
readGS = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall g p. GlobalPrivate g p -> g
global forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
writePS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> Nick -> Maybe p -> m ()
writePS :: forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> Maybe p -> m ()
writePS Nick
who Maybe p
x = forall (m :: * -> *) g p a.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
Nick -> (Maybe p -> (Maybe p -> LB ()) -> LB a) -> m a
withPS Nick
who (\Maybe p
_ Maybe p -> LB ()
writer -> Maybe p -> LB ()
writer Maybe p
x)
writeGS :: (MonadLBState m, LBState m ~ GlobalPrivate g p)
=> g -> m ()
writeGS :: forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
g -> m ()
writeGS g
g = forall (m :: * -> *) g p.
(MonadLBState m, LBState m ~ GlobalPrivate g p) =>
(g -> (g -> m ()) -> m ()) -> m ()
withGS (\g
_ g -> m ()
writer -> g -> m ()
writer g
g)
writeGlobalState :: ModuleT st LB ()
writeGlobalState :: forall st. ModuleT st LB ()
writeGlobalState = do
Module st
m <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> Module st
theModule
String
mName <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall st. ModuleInfo st -> String
moduleName
forall (m :: * -> *). MonadLogging m => String -> m ()
debugM (String
"saving state for module " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
mName)
case forall st. Module st -> Maybe (Serial st)
moduleSerialize Module st
m of
Maybe (Serial st)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Serial st
ser -> do
st
state' <- forall (m :: * -> *). MonadLBState m => m (LBState m)
readMS
case forall s. Serial s -> s -> Maybe ByteString
serialize Serial st
ser st
state' of
Maybe ByteString
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
out -> do
String
stateFile <- forall (m :: * -> *) a. MonadLB m => LB a -> m a
lb (String -> LB String
findLBFileForWriting String
mName)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
io (String -> ByteString -> IO ()
P.writeFile String
stateFile ByteString
out)
readGlobalState :: Module st -> String -> LB (Maybe st)
readGlobalState :: forall st. Module st -> String -> LB (Maybe st)
readGlobalState Module st
module' String
name = do
forall (m :: * -> *). MonadLogging m => String -> m ()
debugM (String
"loading state for module " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
name)
case forall st. Module st -> Maybe (Serial st)
moduleSerialize Module st
module' of
Just Serial st
ser -> do
Maybe String
mbStateFile <- String -> LB (Maybe String)
findLBFileForReading String
name
case Maybe String
mbStateFile of
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just String
stateFile -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
io forall a b. (a -> b) -> a -> b
$ do
Maybe ByteString
state' <- forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO ByteString
P.readFile String
stateFile forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` \SomeException{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
E.catch (forall (m :: * -> *) a. MonadBase IO m => a -> m a
evaluate forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$!) (forall s. Serial s -> ByteString -> Maybe s
deserialize Serial st
ser forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
state'))
(\SomeException
e -> do
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM forall a b. (a -> b) -> a -> b
$ String
"Error parsing state file for: "
forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (SomeException
e :: SomeException)
forall (m :: * -> *). MonadLogging m => String -> m ()
errorM forall a b. (a -> b) -> a -> b
$ String
"Try removing: "forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
stateFile
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing)
Maybe (Serial st)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing