{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
{-|
Module      : Network.N2O.Core
Description : Core functions
Copyright   : (c) Marat Khafizov, 2018
License     : BSD 3-Clause
Maintainer  : xafizoff@gmail.com
Stability   : experimental
Portability : not portable

Core functions

-}
module Network.N2O.Core (lift, ask, put, get, mkCx, mkReq, protoRun) where

import Data.IORef
import qualified Data.Map.Strict as M
import qualified Data.Binary as B
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text.Lazy as TL
import Control.Exception (SomeException)
import Network.N2O.Types
import Data.Map.Strict (insert, (!?))

-- | 'Context' constructor

mkCx :: Context f a
mkCx = Context :: forall (f :: * -> *) a.
(Event a -> N2O f a (Result a))
-> Req
-> [Context f a -> Context f a]
-> [Proto f a]
-> (ByteString -> Maybe a)
-> (a -> ByteString)
-> Map ByteString ByteString
-> Context f a
Context
  { cxReq :: Req
cxReq = Req
forall a. HasCallStack => a
undefined
  , cxHandler :: Event a -> N2O f a (Result a)
cxHandler = Event a -> N2O f a (Result a)
forall a. HasCallStack => a
undefined
  , cxMiddleware :: [Context f a -> Context f a]
cxMiddleware = []
  , cxDePickle :: ByteString -> Maybe a
cxDePickle = ByteString -> Maybe a
forall a. HasCallStack => a
undefined
  , cxPickle :: a -> ByteString
cxPickle = a -> ByteString
forall a. HasCallStack => a
undefined
  , cxProtos :: [Proto f a]
cxProtos = []
  , cxState :: Map ByteString ByteString
cxState = Map ByteString ByteString
forall k a. Map k a
M.empty
  }

-- | 'Req' constructor

mkReq :: Req
mkReq = Req :: ByteString -> ByteString -> ByteString -> [Header] -> Req
Req { reqPath :: ByteString
reqPath = ByteString
"/", reqMeth :: ByteString
reqMeth = ByteString
"GET", reqVers :: ByteString
reqVers = ByteString
"HTTP/1.1", reqHead :: [Header]
reqHead = [] }

-- | NO-OP result

nop :: Result a
nop :: Result a
nop = Result a
forall a. Result a
Empty

-- | N2O protocol loop

protoRun :: f a -> [Proto f a] -> N2O f a (Result (f a))
protoRun :: f a -> [Proto f a] -> N2O f a (Result (f a))
protoRun = [Result (f a)] -> f a -> [Proto f a] -> N2O f a (Result (f a))
forall (f :: * -> *) a.
[Result (f a)]
-> f a -> [Proto f a] -> N2OT (State f a) IO (Result (f a))
loop []
  where
    loop :: [Result (f a)]
-> f a -> [Proto f a] -> N2OT (State f a) IO (Result (f a))
loop [Result (f a)]
_ f a
_ [] = Result (f a) -> N2OT (State f a) IO (Result (f a))
forall (m :: * -> *) a. Monad m => a -> m a
return Result (f a)
forall a. Result a
nop
    loop [Result (f a)]
acc f a
msg (Proto f a
proto:[Proto f a]
protos) = do
      Result (f a)
res <- Proto f a -> f a -> N2OT (State f a) IO (Result (f a))
forall (f :: * -> *) a. Proto f a -> f a -> N2O f a (Result (f a))
protoInfo Proto f a
proto f a
msg
      case Result (f a)
res of
        Result (f a)
Unknown -> [Result (f a)]
-> f a -> [Proto f a] -> N2OT (State f a) IO (Result (f a))
loop [Result (f a)]
acc f a
msg [Proto f a]
protos
        Result (f a)
Empty -> Result (f a) -> N2OT (State f a) IO (Result (f a))
forall (m :: * -> *) a. Monad m => a -> m a
return Result (f a)
forall a. Result a
Empty
        Reply f a
msg1 -> Result (f a) -> N2OT (State f a) IO (Result (f a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Result (f a) -> N2OT (State f a) IO (Result (f a)))
-> Result (f a) -> N2OT (State f a) IO (Result (f a))
forall a b. (a -> b) -> a -> b
$ f a -> Result (f a)
forall a. a -> Result a
Reply f a
msg1
        Result (f a)
a -> [Result (f a)]
-> f a -> [Proto f a] -> N2OT (State f a) IO (Result (f a))
loop (Result (f a)
a Result (f a) -> [Result (f a)] -> [Result (f a)]
forall a. a -> [a] -> [a]
: [Result (f a)]
acc) f a
msg [Proto f a]
protos

-- | Lift underlying monad to the N2O monad

lift :: m a -> N2OT state m a
lift :: m a -> N2OT state m a
lift m a
m = (state -> m a) -> N2OT state m a
forall state (m :: * -> *) a. (state -> m a) -> N2OT state m a
N2OT (m a -> state -> m a
forall a b. a -> b -> a
const m a
m)

-- | Get current state (env)

ask :: (Monad m) => N2OT state m state
ask :: N2OT state m state
ask = (state -> m state) -> N2OT state m state
forall state (m :: * -> *) a. (state -> m a) -> N2OT state m a
N2OT state -> m state
forall (m :: * -> *) a. Monad m => a -> m a
return

getContext :: N2OT (IORef b) IO b
getContext = do
  IORef b
ref <- N2OT (IORef b) IO (IORef b)
forall (m :: * -> *) state. Monad m => N2OT state m state
ask
  IO b -> N2OT (IORef b) IO b
forall (m :: * -> *) a state. m a -> N2OT state m a
lift (IO b -> N2OT (IORef b) IO b) -> IO b -> N2OT (IORef b) IO b
forall a b. (a -> b) -> a -> b
$ IORef b -> IO b
forall a. IORef a -> IO a
readIORef IORef b
ref

-- | Put data to the local state

put :: (B.Binary bin) => BS.ByteString -> bin -> N2O f a ()
put :: ByteString -> bin -> N2O f a ()
put ByteString
k bin
v = do
  State f a
state <- N2OT (State f a) IO (State f a)
forall (m :: * -> *) state. Monad m => N2OT state m state
ask
  IO () -> N2O f a ()
forall (m :: * -> *) a state. m a -> N2OT state m a
lift (IO () -> N2O f a ()) -> IO () -> N2O f a ()
forall a b. (a -> b) -> a -> b
$ State f a -> (Context f a -> Context f a) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef State f a
state (\cx :: Context f a
cx@Context{cxState :: forall (f :: * -> *) a. Context f a -> Map ByteString ByteString
cxState=Map ByteString ByteString
m} -> Context f a
cx{cxState :: Map ByteString ByteString
cxState=ByteString
-> ByteString
-> Map ByteString ByteString
-> Map ByteString ByteString
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert ByteString
k (bin -> ByteString
forall a. Binary a => a -> ByteString
B.encode bin
v) Map ByteString ByteString
m})

-- | Get data from the local state

get :: (B.Binary bin) => BS.ByteString -> N2O f a (Maybe bin)
get :: ByteString -> N2O f a (Maybe bin)
get ByteString
k = do
  State f a
state <- (State f a -> IO (State f a)) -> N2OT (State f a) IO (State f a)
forall state (m :: * -> *) a. (state -> m a) -> N2OT state m a
N2OT State f a -> IO (State f a)
forall (m :: * -> *) a. Monad m => a -> m a
return
  Context f a
cx <- IO (Context f a) -> N2OT (State f a) IO (Context f a)
forall (m :: * -> *) a state. m a -> N2OT state m a
lift (IO (Context f a) -> N2OT (State f a) IO (Context f a))
-> IO (Context f a) -> N2OT (State f a) IO (Context f a)
forall a b. (a -> b) -> a -> b
$ State f a -> IO (Context f a)
forall a. IORef a -> IO a
readIORef State f a
state
  let mp :: Map ByteString ByteString
mp = Context f a -> Map ByteString ByteString
forall (f :: * -> *) a. Context f a -> Map ByteString ByteString
cxState Context f a
cx
  case Map ByteString ByteString
mp Map ByteString ByteString -> ByteString -> Maybe ByteString
forall k a. Ord k => Map k a -> k -> Maybe a
!? ByteString
k of
    Just ByteString
v -> Maybe bin -> N2O f a (Maybe bin)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe bin -> N2O f a (Maybe bin))
-> Maybe bin -> N2O f a (Maybe bin)
forall a b. (a -> b) -> a -> b
$ bin -> Maybe bin
forall a. a -> Maybe a
Just (ByteString -> bin
forall a. Binary a => ByteString -> a
B.decode ByteString
v)
    Maybe ByteString
_ -> Maybe bin -> N2O f a (Maybe bin)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe bin
forall a. Maybe a
Nothing