1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
|
module Service (
Service(..),
SomeService(..), fromService,
ServiceHandler,
ServiceInput(..), ServiceState(..),
handleServicePacket,
svcSet,
svcPrint,
) where
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Typeable
import Identity
import State
import Storage
class (Typeable s, Storable (ServicePacket s)) => Service s where
type ServicePacket s :: *
emptyServiceState :: s
serviceHandler :: Stored (ServicePacket s) -> ServiceHandler s (Maybe (ServicePacket s))
data SomeService = forall s. Service s => SomeService s
fromService :: Service s => SomeService -> Maybe s
fromService (SomeService s) = cast s
data ServiceInput = ServiceInput
{ svcPeer :: UnifiedIdentity
, svcPeerOwner :: UnifiedIdentity
, svcPrintOp :: String -> IO ()
}
data ServiceState s = ServiceState
{ svcValue :: s
, svcLocal :: Stored LocalState
}
newtype ServiceHandler s a = ServiceHandler (ReaderT ServiceInput (StateT (ServiceState s) (ExceptT String IO)) a)
deriving (Functor, Applicative, Monad, MonadReader ServiceInput, MonadState (ServiceState s), MonadError String, MonadIO)
handleServicePacket :: Service s => Storage -> ServiceInput -> s -> Stored (ServicePacket s) -> IO (Maybe (ServicePacket s), s)
handleServicePacket st input svc packet = do
herb <- loadLocalState st
let erb = wrappedLoad $ headRef herb
sstate = ServiceState { svcValue = svc, svcLocal = erb }
ServiceHandler handler = serviceHandler packet
(runExceptT $ flip runStateT sstate $ flip runReaderT input $ handler) >>= \case
Left err -> do
svcPrintOp input $ "service failed: " ++ err
return (Nothing, svc)
Right (rsp, sstate')
| svcLocal sstate' == svcLocal sstate -> return (rsp, svcValue sstate')
| otherwise -> replaceHead (svcLocal sstate') (Right herb) >>= \case
Left _ -> handleServicePacket st input svc packet
Right _ -> return (rsp, svcValue sstate')
svcSet :: s -> ServiceHandler s ()
svcSet x = modify $ \st -> st { svcValue = x }
svcPrint :: String -> ServiceHandler s ()
svcPrint str = liftIO . ($str) =<< asks svcPrintOp
|