module Data.Radius.StreamGet.Base (
  upacket, packet,

  header, attribute', vendorID, simpleVendorAttribute,

  code, bin128,

  atText, atString, atInteger, atIpV4,

  eof,
  ) where

import Control.Applicative ((<$>), pure, (<*>), (<*), (<|>), many)
import Control.Monad (guard)
import Data.ByteString (ByteString)
import Data.Word (Word8, Word32)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Serialize.Get
  (Get, getWord8, getWord16be, getWord32be,
   getBytes, isEmpty, runGet)

import Data.Radius.Scalar
  (Bin128, mayBin128, AtText (..), AtString (..), AtInteger (..), AtIpV4 (..))
import Data.Radius.Packet
  (Code, Header (Header), Packet (Packet), codeFromWord)
import qualified Data.Radius.Packet as Data
import Data.Radius.Attribute (NumberAbstract (..), Attribute' (..))
import qualified Data.Radius.Attribute as Attribute


code :: Get Code
code :: Get Code
code = Word8 -> Code
codeFromWord (Word8 -> Code) -> Get Word8 -> Get Code
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

pktId :: Get Word8
pktId :: Get Word8
pktId = Get Word8
getWord8

bin128 :: Get Bin128
bin128 :: Get Bin128
bin128 =
  Get Bin128 -> (Bin128 -> Get Bin128) -> Maybe Bin128 -> Get Bin128
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
  (String -> Get Bin128
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Illegal state: Bin128")
  Bin128 -> Get Bin128
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  (Maybe Bin128 -> Get Bin128)
-> (ByteString -> Maybe Bin128) -> ByteString -> Get Bin128
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Bin128
mayBin128 (ByteString -> Get Bin128) -> Get ByteString -> Get Bin128
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> Get ByteString
getBytes Int
16

header :: Get Header
header :: Get Header
header =
  Code -> Word8 -> Word16 -> Bin128 -> Header
Header
  (Code -> Word8 -> Word16 -> Bin128 -> Header)
-> Get Code -> Get (Word8 -> Word16 -> Bin128 -> Header)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Code
code
  Get (Word8 -> Word16 -> Bin128 -> Header)
-> Get Word8 -> Get (Word16 -> Bin128 -> Header)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word8
pktId
  Get (Word16 -> Bin128 -> Header)
-> Get Word16 -> Get (Bin128 -> Header)
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word16
getWord16be
  Get (Bin128 -> Header) -> Get Bin128 -> Get Header
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Bin128
bin128

eof :: Get ()
eof :: Get ()
eof = Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Get ()) -> Get Bool -> Get ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Bool
isEmpty

packet :: Get a -> Get (Packet a)
packet :: forall a. Get a -> Get (Packet a)
packet Get a
getAttrs = do
  Header
h   <-  Get Header
header
  let alen :: Int
alen = Word16 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Header -> Word16
Data.pktLength Header
h) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
20 {- sizeof(code) + sizeof(pktId) + sizeof(pkgLength) + sizeof(authenticator) -}
  Bool -> Get ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
alen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0) Get () -> Get () -> Get ()
forall a. Get a -> Get a -> Get a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Get ()
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Parse error of header: Packet: invalid length: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
alen)
  ByteString
bs  <-  Int -> Get ByteString
getBytes Int
alen
  (String -> Get (Packet a))
-> (a -> Get (Packet a)) -> Either String a -> Get (Packet a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (String -> Get (Packet a)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Packet a))
-> (String -> String) -> String -> Get (Packet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Parse error of attributes: Packet: " String -> String -> String
forall a. [a] -> [a] -> [a]
++))
    (Packet a -> Get (Packet a)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Packet a -> Get (Packet a))
-> (a -> Packet a) -> a -> Get (Packet a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> a -> Packet a
forall a. Header -> a -> Packet a
Packet Header
h)
    (Either String a -> Get (Packet a))
-> Either String a -> Get (Packet a)
forall a b. (a -> b) -> a -> b
$ Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
runGet (Get a
getAttrs Get a -> Get () -> Get a
forall a b. Get a -> Get b -> Get a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Get ()
eof) ByteString
bs

radiusNumber :: Get Attribute.Number
radiusNumber :: Get Number
radiusNumber = Word8 -> Number
Attribute.fromWord (Word8 -> Number) -> Get Word8 -> Get Number
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8

vendorID :: Get Word32
vendorID :: Get Word32
vendorID = Get Word32
getWord32be

simpleVendorAttribute :: Get (Word8, ByteString)
simpleVendorAttribute :: Get (Word8, ByteString)
simpleVendorAttribute = do
  Word8
n    <-  Get Word8
getWord8
  Word8
len  <-  Get Word8
getWord8
  ByteString
bs   <-  Int -> Get ByteString
getBytes (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 {- sizeof(number) + sizeof(attribute length) -}
  (Word8, ByteString) -> Get (Word8, ByteString)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Word8, ByteString) -> Get (Word8, ByteString))
-> (Word8, ByteString) -> Get (Word8, ByteString)
forall a b. (a -> b) -> a -> b
$ (Word8
n, ByteString
bs)

-- {26, length, vendorID(45137), サブ属性番号, サブ属性 length, サブ属性値}

attribute' :: Get (Attribute' v) -> Get (Attribute' v)
attribute' :: forall v. Get (Attribute' v) -> Get (Attribute' v)
attribute' Get (Attribute' v)
va = do
  Number
n    <- Get Number
radiusNumber
  Word8
len  <- Get Word8
getWord8
  ByteString
bs   <- Int -> Get ByteString
getBytes (Int -> Get ByteString) -> Int -> Get ByteString
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
len Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 {- sizeof(number) + sizeof(attribute length) -}
  case Number
n of
    Number
Attribute.VendorSpecific ->
      (String -> Get (Attribute' v))
-> (Attribute' v -> Get (Attribute' v))
-> Either String (Attribute' v)
-> Get (Attribute' v)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Get (Attribute' v)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Attribute' v))
-> (String -> String) -> String -> Get (Attribute' v)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Parse error of Vendor-Specific attribute: " String -> String -> String
forall a. [a] -> [a] -> [a]
++)) Attribute' v -> Get (Attribute' v)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Either String (Attribute' v) -> Get (Attribute' v))
-> Either String (Attribute' v) -> Get (Attribute' v)
forall a b. (a -> b) -> a -> b
$ Get (Attribute' v) -> ByteString -> Either String (Attribute' v)
forall a. Get a -> ByteString -> Either String a
runGet Get (Attribute' v)
va ByteString
bs
    Number
_                     ->
      Attribute' v -> Get (Attribute' v)
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute' v -> Get (Attribute' v))
-> Attribute' v -> Get (Attribute' v)
forall a b. (a -> b) -> a -> b
$ NumberAbstract v -> ByteString -> Attribute' v
forall v. NumberAbstract v -> ByteString -> Attribute' v
Attribute' (Number -> NumberAbstract v
forall a. Number -> NumberAbstract a
Standard Number
n) ByteString
bs

upacket :: Get (Attribute' v) -> Get (Packet [Attribute' v])
upacket :: forall v. Get (Attribute' v) -> Get (Packet [Attribute' v])
upacket Get (Attribute' v)
va = Get [Attribute' v] -> Get (Packet [Attribute' v])
forall a. Get a -> Get (Packet a)
packet (Get [Attribute' v] -> Get (Packet [Attribute' v]))
-> Get [Attribute' v] -> Get (Packet [Attribute' v])
forall a b. (a -> b) -> a -> b
$ Get (Attribute' v) -> Get [Attribute' v]
forall a. Get a -> Get [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Get (Attribute' v) -> Get [Attribute' v])
-> Get (Attribute' v) -> Get [Attribute' v]
forall a b. (a -> b) -> a -> b
$ Get (Attribute' v) -> Get (Attribute' v)
forall v. Get (Attribute' v) -> Get (Attribute' v)
attribute' Get (Attribute' v)
va


atText :: Int -> Get AtText
atText :: Int -> Get AtText
atText Int
len
  | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
253  =  (UnicodeException -> Get AtText)
-> (Text -> Get AtText)
-> Either UnicodeException Text
-> Get AtText
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
                               (String -> Get AtText
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get AtText)
-> (UnicodeException -> String) -> UnicodeException -> Get AtText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Get.atText: fail to decode UTF8: " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (UnicodeException -> String) -> UnicodeException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show)
                               (AtText -> Get AtText
forall a. a -> Get a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AtText -> Get AtText) -> (Text -> AtText) -> Text -> Get AtText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AtText
AtText (String -> AtText) -> (Text -> String) -> Text -> AtText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack)
                               (Either UnicodeException Text -> Get AtText)
-> Get (Either UnicodeException Text) -> Get AtText
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> Either UnicodeException Text
Text.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> Get ByteString -> Get (Either UnicodeException Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
len
  | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
253               =  String -> Get AtText
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get AtText) -> String -> Get AtText
forall a b. (a -> b) -> a -> b
$ String
"Get.atText: Too long: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len
  | Bool
otherwise               =  String -> Get AtText
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get AtText) -> String -> Get AtText
forall a b. (a -> b) -> a -> b
$ String
"Get.atText: Positive length required: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len

atString :: Int -> Get AtString
atString :: Int -> Get AtString
atString Int
len
  | Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
len Bool -> Bool -> Bool
&& Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
253  =  ByteString -> AtString
AtString (ByteString -> AtString) -> Get ByteString -> Get AtString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
getBytes Int
len
  | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
253               =  String -> Get AtString
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get AtString) -> String -> Get AtString
forall a b. (a -> b) -> a -> b
$ String
"Get.atString: Too long: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len
  | Bool
otherwise               =  String -> Get AtString
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get AtString) -> String -> Get AtString
forall a b. (a -> b) -> a -> b
$ String
"Get.atString: Positive length required: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
len

atInteger :: Get AtInteger
atInteger :: Get AtInteger
atInteger = Word32 -> AtInteger
AtInteger (Word32 -> AtInteger) -> Get Word32 -> Get AtInteger
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be

atIpV4 :: Get AtIpV4
atIpV4 :: Get AtIpV4
atIpV4 = Word32 -> AtIpV4
AtIpV4 (Word32 -> AtIpV4) -> Get Word32 -> Get AtIpV4
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32be