module Data.Radius.StreamPut.Monadic (
  -- * DSL to build attribute list of packet
  AttributePutM, extractAttributes,

  tellA,

  -- * low-level definitions
  AtValueEncode,
  exAttribute, attribute,
  ) where

import Control.Applicative (pure)
import Control.Monad.Trans.Writer (Writer, runWriter, tell)
import Data.DList (DList)
import qualified Data.DList as DList
import Data.Serialize.Put (Put, runPut)

import Data.Radius.Scalar (AtText, AtString, AtInteger, AtIpV4)
import Data.Radius.Attribute
  (Attribute (..), untypeNumber, TypedNumber, Attribute' (..))
import qualified Data.Radius.StreamPut.Base as Base


class AtValueEncode a where
  atValueEncode :: a -> Put

instance AtValueEncode AtText where
  atValueEncode :: AtText -> Put
atValueEncode = AtText -> Put
Base.atText

instance AtValueEncode AtString where
  atValueEncode :: AtString -> Put
atValueEncode = AtString -> Put
Base.atString

instance AtValueEncode AtInteger where
  atValueEncode :: AtInteger -> Put
atValueEncode = AtInteger -> Put
Base.atInteger

instance AtValueEncode AtIpV4 where
  atValueEncode :: AtIpV4 -> Put
atValueEncode = AtIpV4 -> Put
Base.atIpV4

-- | Context monad type to build attribute list of packet
type AttributePutM v = Writer (DList (Attribute' v))

exAttribute :: (a -> Put) -> Attribute v a -> AttributePutM v ()
exAttribute :: forall a v. (a -> Put) -> Attribute v a -> AttributePutM v ()
exAttribute a -> Put
vp (Attribute TypedNumber v a
n a
v) =
  DList (Attribute' v) -> WriterT (DList (Attribute' v)) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (DList (Attribute' v)
 -> WriterT (DList (Attribute' v)) Identity ())
-> (Put -> DList (Attribute' v))
-> Put
-> WriterT (DList (Attribute' v)) Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attribute' v -> DList (Attribute' v)
forall a. a -> DList a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute' v -> DList (Attribute' v))
-> (Put -> Attribute' v) -> Put -> DList (Attribute' v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumberAbstract v -> ByteString -> Attribute' v
forall v. NumberAbstract v -> ByteString -> Attribute' v
Attribute' (TypedNumber v a -> NumberAbstract v
forall v a. TypedNumber v a -> NumberAbstract v
untypeNumber TypedNumber v a
n) (ByteString -> Attribute' v)
-> (Put -> ByteString) -> Put -> Attribute' v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> WriterT (DList (Attribute' v)) Identity ())
-> Put -> WriterT (DList (Attribute' v)) Identity ()
forall a b. (a -> b) -> a -> b
$ a -> Put
vp a
v

attribute :: AtValueEncode a => Attribute v a -> AttributePutM v ()
attribute :: forall a v. AtValueEncode a => Attribute v a -> AttributePutM v ()
attribute = (a -> Put) -> Attribute v a -> AttributePutM v ()
forall a v. (a -> Put) -> Attribute v a -> AttributePutM v ()
exAttribute a -> Put
forall a. AtValueEncode a => a -> Put
atValueEncode

-- | Add attribute key and value into monadic context
tellA :: AtValueEncode a => TypedNumber v a -> a -> AttributePutM v ()
tellA :: forall a v.
AtValueEncode a =>
TypedNumber v a -> a -> AttributePutM v ()
tellA = (Attribute v a -> AttributePutM v ()
forall a v. AtValueEncode a => Attribute v a -> AttributePutM v ()
attribute (Attribute v a -> AttributePutM v ())
-> (a -> Attribute v a) -> a -> AttributePutM v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((a -> Attribute v a) -> a -> AttributePutM v ())
-> (TypedNumber v a -> a -> Attribute v a)
-> TypedNumber v a
-> a
-> AttributePutM v ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedNumber v a -> a -> Attribute v a
forall v a. TypedNumber v a -> a -> Attribute v a
Attribute

-- | Extract attribute list from context
extractAttributes :: AttributePutM v a -> [Attribute' v]
extractAttributes :: forall v a. AttributePutM v a -> [Attribute' v]
extractAttributes AttributePutM v a
w = DList (Attribute' v) -> [Attribute' v]
forall a. DList a -> [a]
DList.toList DList (Attribute' v)
dl  where
  (a
_, DList (Attribute' v)
dl) = AttributePutM v a -> (a, DList (Attribute' v))
forall w a. Writer w a -> (a, w)
runWriter AttributePutM v a
w