packages feed

protocol-radius (empty) → 0.0.1.0

raw patch · 18 files changed

+1033/−0 lines, 18 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, containers, cryptonite, dlist, memory, template-haskell, text, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for protocol-radius++## 0.0.1.0++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Kei Hibino nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ protocol-radius.cabal view
@@ -0,0 +1,64 @@+name:                protocol-radius+version:             0.0.1.0+synopsis:            parser and printer for radius protocol packet+description:         This package provides+                     parser and printer for radius protocol packet.+license:             BSD3+license-file:        LICENSE+author:              Kei Hibino+maintainer:          ex8k.hibino@gmail.com+-- copyright:+category:            Network+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.10+tested-with:           GHC == 8.2.1, GHC == 8.2.2+                     , GHC == 8.0.1, GHC == 8.0.2+                     , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3+                     , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4+                     , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3++library+  exposed-modules:+                       Data.Radius.Packet+                       Data.Radius.Implements+                       Data.Radius.Scalar+                       Data.Radius.Attribute+                       Data.Radius.Attribute.Number+                       Data.Radius.Attribute.Pair+                       Data.Radius.Attribute.Instances+                       Data.Radius.Attribute.TH+                       Data.Radius.StreamGet+                       Data.Radius.StreamGet.Base+                       Data.Radius.StreamGet.Monadic+                       Data.Radius.StreamPut+                       Data.Radius.StreamPut.Base+                       Data.Radius.StreamPut.Monadic+  -- other-modules:+  other-extensions:+                       DeriveFunctor+                       DeriveFoldable+                       DeriveTraversable+                       TemplateHaskell+                       ExplicitForAll+  build-depends:         base <5+                       , bytestring+                       , text+                       , transformers+                       , dlist+                       , containers+                       , template-haskell+                       , cereal+                       , memory >=0.13+                       , cryptonite >=0.13+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++source-repository head+  type:       git+  location:   https://github.com/khibino/haskell-protocol-radius++source-repository head+  type:       mercurial+  location:   https://bitbucket.org/khibino/haskell-protocol-radius
+ src/Data/Radius/Attribute.hs view
@@ -0,0 +1,9 @@+module Data.Radius.Attribute (+  module Data.Radius.Attribute.Number,+  module Data.Radius.Attribute.Pair,+  module Data.Radius.Attribute.Instances,+  ) where++import Data.Radius.Attribute.Number+import Data.Radius.Attribute.Pair+import Data.Radius.Attribute.Instances
+ src/Data/Radius/Attribute/Instances.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.Radius.Attribute.Instances where++import Data.Radius.Attribute.Number (Number (..))+import Data.Radius.Attribute.Pair (NumberAbstract (..))+import Data.Radius.Attribute.TH (unsafeTypedNumberSetTemplate)+import Data.Radius.Scalar(AtText, AtString, AtInteger, AtIpV4)+++$(unsafeTypedNumberSetTemplate+ "numbersText"  Nothing [t|AtText|]+ [ ([| Standard |], ['ReplyMessage]) ])++$(unsafeTypedNumberSetTemplate+ "numbersString"  Nothing [t|AtString|]+ [ ([| Standard |], [ 'UserName, 'ProxyState, 'State, 'MessageAuthenticator]) ])++$(unsafeTypedNumberSetTemplate+  "numbersInteger"   Nothing [t|AtInteger|]+  [])++$(unsafeTypedNumberSetTemplate+  "numbersIpV4"   Nothing [t|AtIpV4|]+  [])
+ src/Data/Radius/Attribute/Number.hs view
@@ -0,0 +1,40 @@+-- |+--+module Data.Radius.Attribute.Number (+  Number (..),++  toWord, fromWord,+  ) where++import Data.Word (Word8)+++data Number+  = UserName+  | ProxyState+  | State+  | MessageAuthenticator+  | ReplyMessage+  | VendorSpecific+  | Other !Word8+  deriving (Eq, Ord, Show, Read)++toWord :: Number -> Word8+toWord = d  where+  d UserName              =   1+  d ReplyMessage          =  18+  d State                 =  24+  d VendorSpecific        =  26+  d ProxyState            =  33+  d MessageAuthenticator  =  80+  d (Other w8)            =  w8++fromWord :: Word8 -> Number+fromWord = d  where+  d  1  =  UserName+  d 18  =  ReplyMessage+  d 24  =  State+  d 26  =  VendorSpecific+  d 33  =  ProxyState+  d 80  =  MessageAuthenticator+  d w8  =  Other w8
+ src/Data/Radius/Attribute/Pair.hs view
@@ -0,0 +1,80 @@++module Data.Radius.Attribute.Pair (+  NumberAbstract (..),++  TypedNumber, unsafeTypedNumber, untypeNumber,++  Attribute' (..), Attribute (..), value,++  TypedNumberSet, typed,++  TypedNumberSets (..),+  ) where++import Control.Applicative ((<$>))+import Control.Monad (guard)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Data.ByteString (ByteString)+import Data.Set (Set)+import qualified Data.Set as Set++import Data.Radius.Scalar (AtText, AtString, AtInteger, AtIpV4, )+import qualified Data.Radius.Attribute.Number as Radius+++data NumberAbstract a+  = Standard Radius.Number+  | Vendors  a+  deriving (Eq, Ord, Show)+++newtype TypedNumber v a =+  TypedNumber (NumberAbstract v)+  deriving (Eq, Ord, Show)++unsafeTypedNumber :: NumberAbstract v -> TypedNumber v a+unsafeTypedNumber = TypedNumber++untypeNumber :: TypedNumber v a -> NumberAbstract v+untypeNumber (TypedNumber n) = n++data Attribute' v =+  Attribute' !(NumberAbstract v) !ByteString+  deriving (Eq, Ord, Show)++data Attribute v a =+  Attribute !(TypedNumber v a) !a+  deriving (Eq, Ord, Show)++value :: Attribute v a -> a+value (Attribute _ v) = v+++type TypedNumberSet v a = Set (TypedNumber v a)++{-+-- | Retryable error context with anthor attirbute value type /t/ /m/, and parse error context /m/.+typed :: (Monad m, Functor m, MonadTrans t, MonadPlus (t m))+      => TypedNumberSet vt+      -> (ByteString -> m a)+      -> Attribute'+      -> t m (Attribute a)+ -}+-- | Retryable error context with anthor attirbute value type 'MaybeT' /m/, and parse error context /m/.+typed :: (Monad m, Functor m, Ord v)+      => TypedNumberSet v a+      -> (ByteString -> m b)+      -> Attribute' v+      -> MaybeT m (Attribute v b)+typed s parse (Attribute' n d) = do+  let typedAN = unsafeTypedNumber n+  guard $ typedAN `Set.member` s+  lift $ Attribute typedAN <$> parse d+++class TypedNumberSets v where+  attributeNumbersText    :: TypedNumberSet v AtText+  attributeNumbersString  :: TypedNumberSet v AtString+  attributeNumbersInteger :: TypedNumberSet v AtInteger+  attributeNumbersIpV4    :: TypedNumberSet v AtIpV4
+ src/Data/Radius/Attribute/TH.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExplicitForAll #-}++module Data.Radius.Attribute.TH (+  unsafeTypedNumberSetTemplate,+  ) where++import Control.Applicative ((<$>), pure)+import Data.Char (toLower)+import qualified Data.Set as Set+import Language.Haskell.TH+  (Name, nameBase, mkName, Q, Type, Exp, Dec,+   sigD, valD, varP, normalB, conE, varE, listE)++import Data.Radius.Attribute.Pair+  (TypedNumber, unsafeTypedNumber, TypedNumberSet)+++varNameFromDCon :: Name -> Name+varNameFromDCon = mkName . d . nameBase  where+  d (c:cs)  =  toLower c : cs+  d  []     =  []++unsafeTypedNumberTemplate :: Maybe (Q Type) -> Q Type -> Q Exp -> Name -> Q ([Dec], Name)+unsafeTypedNumberTemplate mayVsaType valueType abstConE conName  = do+  let varName = varNameFromDCon conName+  sig <- sigD varName $+         maybe+         [t| forall a . Ord a => TypedNumber a $valueType |]+         (\vsaTy -> [t| TypedNumber $vsaTy $valueType |])+         mayVsaType+  val <- valD+         (varP varName)+         (normalB [| unsafeTypedNumber ($abstConE $(conE conName)) |])+         []+  pure ([sig, val], varName)++unsafeTypedNumberSetTemplate :: String+                             -> Maybe (Q Type)+                             -> Q Type+                             -> [(Q Exp, [Name])]+                             -> Q [Dec]+unsafeTypedNumberSetTemplate setVarStr mayVsaType valueType conPairs = do+  decPairs <-+    concat <$> sequence+    [ mapM (unsafeTypedNumberTemplate mayVsaType valueType abstConE) conNames+    | (abstConE, conNames) <- conPairs]++  let setVarName = mkName setVarStr+  setSig <- sigD setVarName $+            maybe+            [t| forall a . Ord a => TypedNumberSet  a     $(valueType) |]+            (\vsaTy -> [t| TypedNumberSet $vsaTy $(valueType) |])+            mayVsaType+  setVal <- valD+            (varP setVarName)+            (normalB [| Set.fromList $(listE [varE n | (_, n) <- decPairs]) |])+            []+  pure $ setSig : setVal : concat [ decs | (decs, _) <- decPairs ]
+ src/Data/Radius/Implements.hs view
@@ -0,0 +1,165 @@++module Data.Radius.Implements (+  signPacket, signedPacket,++  AuthenticatorError (..),++  checkSignedRequest, checkSignedResponse,+  ) where++import Control.Monad (unless)+import Data.Monoid ((<>))+import Data.Word (Word16)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Serialize.Put (Put, runPut)+import qualified Data.ByteArray as BA+import Crypto.Hash (Digest, hash, MD5)+import Crypto.MAC.HMAC (HMAC, hmac, hmacGetDigest)++import Data.Radius.Packet (Code (..), Header (..), Packet (..))+import Data.Radius.Scalar (AtString (..), Bin128, mayBin128, fromBin128, bin128Zero)+import Data.Radius.Attribute+  (Number (MessageAuthenticator), messageAuthenticator,+   NumberAbstract (Standard), Attribute' (Attribute'), TypedNumberSets, )+import Data.Radius.StreamGet (Attributes)+import qualified Data.Radius.StreamGet as Get+import qualified Data.Radius.StreamPut as Put+++hmacMD5 :: ByteString -> ByteString -> Bin128+hmacMD5 rsk bs =+  maybe (error "hmacMD5: BUG? Invalid result length") id+  . mayBin128 . BA.convert $ hmacGetDigest (hmac rsk bs :: HMAC MD5)++md5 :: ByteString -> Bin128+md5 bs = maybe (error "md5: BUG? Invalid result length") id+         . mayBin128 $ BA.convert (hash bs :: Digest MD5)++-- | Make signatures for response packet.+--   When you don't want to use message authenticator attribute,+--   pass a function to make attributes which doesn't use message authenticator argument.+signPacket :: (a -> ByteString -> Put)     -- ^ Printer for vendor specific attribute+           -> ByteString                   -- ^ Radius secret key+           -> Bin128                       -- ^ Request authenticator+           -> (Word16 -> Bin128 -> Header) -- ^ Function to make header+           -> (Bin128 -> [Attribute' a])   -- ^ Function to make attributes from message authenticator+           -> (Word16, Bin128, Bin128)     -- ^ Packet length, message authenticator and response authenticator+signPacket va rsk auth mkH mkA = (len, msgAuth, respAuth)+  where+    asMsgAuth0 = mkA bin128Zero+    pput = runPut . Put.upacket va+    len = fromIntegral . BS.length . pput+          $ Packet { header = mkH 0 auth, attributes = asMsgAuth0 }+    msgAuth = hmacMD5 rsk . pput+              $ Packet { header = mkH len auth, attributes = asMsgAuth0 }+    respAuth = md5 $ (pput $ Packet { header = mkH len auth, attributes = mkA msgAuth }) <> rsk++signedPacket :: (a -> ByteString -> Put)     -- ^ Printer for vendor specific attribute+             -> ByteString                   -- ^ Radius secret key+             -> Bin128                       -- ^ Request authenticator+             -> (Word16 -> Bin128 -> Header) -- ^ Function to make header+             -> (Bin128 -> [Attribute' a])   -- ^ Function to make attributes from message authenticator+             -> Packet [Attribute' a]        -- ^ Signed packet+signedPacket va rsk auth mkH mkA = case code $ mkH len auth of+  AccessAccept     ->  response+  AccessReject     ->  response+  AccessChallenge  ->  response++  AccessRequest    ->  other+  Other _          ->  other++  where+    (len, msgAuth, respAuth) = signPacket va rsk auth mkH mkA+    response  =  Packet { header = mkH len respAuth, attributes = mkA msgAuth }+    other     =  Packet { header = mkH len auth    , attributes = mkA msgAuth }++data AuthenticatorError v+  = NoMessageAuthenticator (Attributes v) -- ^ No Message-Authenticator attribute++  | BadMessageAuthenticator               -- ^ Message-Authenticator attribute is not matched+  | MoreThanOneMessageAuthenticator       -- ^ More than one Message-Authenticator attribute pairs found++  | BadAuthenticator                      -- ^ Radius packet authenticator is not matched++  | AttributesDecodeError String          -- ^ Fail to decode attributes, attribute type error etc.++  | NotRequestPacket Code                 -- ^ Not request packet is passed to function to check request packet+  | NotResponsePacket Code                -- ^ Not response packet is passed to function to check response packet++instance Show (AuthenticatorError v) where+  show = d  where+    d (NoMessageAuthenticator _)        =  "no messageAuthenticator found"+    d  BadMessageAuthenticator          =  "bad messageAuthenticator"+    d  MoreThanOneMessageAuthenticator  =  "more than one messageAuthenticator found"+    d  BadAuthenticator                 =  "bad radius packet authenticator"+    d (AttributesDecodeError s)         =  "fail to decode attributes: " ++ s+    d (NotRequestPacket c)              =  "not request packet: code: " ++ show c+    d (NotResponsePacket c)             =  "not response packet: code: " ++ show c++checkSignedRequest :: (TypedNumberSets a, Ord a)+                   => (a -> ByteString -> Put)     -- ^ Printer for vendor specific attribute+                   -> ByteString+                   -> Packet [Attribute' a]+                   -> Either (AuthenticatorError a) (Attributes a)+checkSignedRequest va rsk upkt = case code $ header upkt of+  c@AccessAccept     ->  notRequestCode c+  c@AccessReject     ->  notRequestCode c+  c@AccessChallenge  ->  notRequestCode c++  AccessRequest      ->  check+  Other _            ->  check+  where+    notRequestCode = Left . NotRequestPacket++    check  =  checkMA calcMsgAuth $ attrs+    attrs  =  attributes upkt+    calcMsgAuth = hmacMD5 rsk . runPut . Put.upacket va+                  $ upkt { attributes = replace0MA attrs }++checkSignedResponse :: (TypedNumberSets a, Ord a)+                    => (a -> ByteString -> Put)     -- ^ Printer for vendor specific attribute+                    -> ByteString+                    -> Bin128+                    -> Packet [Attribute' a]+                    -> Either (AuthenticatorError a) (Attributes a)+checkSignedResponse va rsk reqAuth upkt = case code $ header upkt of+  AccessAccept     ->  check+  AccessReject     ->  check+  AccessChallenge  ->  check++  c@AccessRequest  ->  notResponseCode c+  c@(Other _)      ->  notResponseCode c+  where+    notResponseCode = Left . NotResponsePacket++    check  =  do+      unless (authenticator (header upkt) == calcRespAuth) $ Left BadAuthenticator+      checkMA calcMsgAuth attrs+    attrs  =  attributes upkt+    calcRespAuth = md5+                   $ (runPut . Put.upacket va $ upkt { header = (header upkt) { authenticator = reqAuth } }) <> rsk+    calcMsgAuth = hmacMD5 rsk . runPut . Put.upacket va+                  $ upkt { header = (header upkt) { authenticator = reqAuth }+                         , attributes = replace0MA attrs }+++checkMA :: (TypedNumberSets a, Ord a)+        => Bin128 -> [Attribute' a] -> Either (AuthenticatorError a) (Attributes a)+checkMA calcMsgAuth attrs  = do+  ta  <-  either (Left . AttributesDecodeError) return . Get.extractAttributes $ mapM Get.tellT attrs+  case Get.takeTyped ta messageAuthenticator of+    []             ->  Left $ NoMessageAuthenticator ta+    [AtString bs]  ->  do+      unless (bs == fromBin128 calcMsgAuth) $ Left BadMessageAuthenticator+      return ta+    _:_:_          ->  Left MoreThanOneMessageAuthenticator++replace0MA :: [Attribute' a] -> [Attribute' a]+replace0MA = rec'  where+  rec'  []                                       =+    []+  rec' (Attribute' n@(Standard MessageAuthenticator) _ : xs)  =+    Attribute' n (fromBin128 bin128Zero) : rec' xs+  rec' (x                                              : xs)  =+    x : rec' xs
+ src/Data/Radius/Packet.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Data.Radius.Packet (+  codeToWord, codeFromWord,++  Code (..), Header (..), Packet (..),+  ) where++import Data.Word (Word8, Word16)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)++import Data.Radius.Scalar (Bin128)+++data Code+  = AccessRequest+  | AccessAccept+  | AccessReject++  | AccessChallenge++  | Other Word8+  deriving (Eq, Ord, Show)++codeToWord :: Code -> Word8+codeToWord =  d  where+  d AccessRequest    =   1+  d AccessAccept     =   2+  d AccessReject     =   3+  d AccessChallenge  =  11+  d (Other w) = w++codeFromWord :: Word8 -> Code+codeFromWord = d  where+  d  1  =  AccessRequest+  d  2  =  AccessAccept+  d  3  =  AccessReject+  d 11  =  AccessChallenge+  d  w  =  Other w+++data Header =+  Header+  { code           ::  !Code+  , pktId          ::  !Word8+  , pktLength      ::  !Word16+  , authenticator  ::  !Bin128+  } deriving (Eq, Show)++data Packet a =+  Packet+  { header      ::  !Header+  , attributes  ::  !a+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+ src/Data/Radius/Scalar.hs view
@@ -0,0 +1,34 @@++module Data.Radius.Scalar (+  AtText (..), AtString (..), AtInteger (..), AtIpV4 (..),+  Bin128, fromBin128, mayBin128, word64Bin128, bin128Zero,+  ) where++import Data.Monoid ((<>))+import Data.Word (Word32, Word64)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Lazy (toStrict)+import Data.Serialize (encodeLazy)+++newtype AtText     =  AtText     { unAtText :: String }        deriving (Eq, Ord, Show)+newtype AtString   =  AtString   { unAtString :: ByteString }  deriving (Eq, Ord, Show)+newtype AtInteger  =  AtInteger  { unAtInteger :: Word32 }     deriving (Eq, Ord, Show)+newtype AtIpV4     =  AtIpV4     { unAtIpV4 :: Word32 }        deriving (Eq, Ord, Show)++newtype Bin128  =  Bin128 ByteString deriving (Eq, Ord, Show)++fromBin128 :: Bin128 -> ByteString+fromBin128 (Bin128 s) = s++mayBin128 :: ByteString -> Maybe Bin128+mayBin128 bs+  | BS.length bs == 16 = Just $ Bin128 bs+  | otherwise          = Nothing++word64Bin128 :: Word64 -> Word64 -> Bin128+word64Bin128 h l = Bin128 . toStrict $ encodeLazy h <> encodeLazy l++bin128Zero :: Bin128+bin128Zero = word64Bin128 0 0
+ src/Data/Radius/StreamGet.hs view
@@ -0,0 +1,7 @@+module Data.Radius.StreamGet (+  module Data.Radius.StreamGet.Base,+  module Data.Radius.StreamGet.Monadic,+  ) where++import Data.Radius.StreamGet.Base+import Data.Radius.StreamGet.Monadic
+ src/Data/Radius/StreamGet/Base.hs view
@@ -0,0 +1,117 @@+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 = codeFromWord <$> getWord8++pktId :: Get Word8+pktId = getWord8++bin128 :: Get Bin128+bin128 =+  maybe+  (fail "Illegal state: Bin128")+  pure+  . mayBin128 =<< getBytes 16++header :: Get Header+header =+  Header+  <$> code+  <*> pktId+  <*> getWord16be+  <*> bin128++eof :: Get ()+eof = guard =<< isEmpty++packet :: Get a -> Get (Packet a)+packet getAttrs = do+  h   <-  header+  let alen = fromIntegral (Data.pktLength h) - 20 {- sizeof(code) + sizeof(pktId) + sizeof(pkgLength) + sizeof(authenticator) -}+  guard (alen >= 0) <|> fail ("Parse error of header: Packet: invalid length: " ++ show alen)+  bs  <-  getBytes alen+  either+    (fail . ("Parse error of attributes: Packet: " ++))+    (pure . Packet h)+    $ runGet (getAttrs <* eof) bs++radiusNumber :: Get Attribute.Number+radiusNumber = Attribute.fromWord <$> getWord8++vendorID :: Get Word32+vendorID = getWord32be++simpleVendorAttribute :: Get (Word8, ByteString)+simpleVendorAttribute = do+  n    <-  getWord8+  len  <-  getWord8+  bs   <-  getBytes $ fromIntegral len - 2 {- sizeof(number) + sizeof(attribute length) -}+  pure $ (n, bs)++-- {26, length, vendorID(45137), サブ属性番号, サブ属性 length, サブ属性値}++attribute' :: Get (Attribute' v) -> Get (Attribute' v)+attribute' va = do+  n    <- radiusNumber+  len  <- getWord8+  bs   <- getBytes $ fromIntegral len - 2 {- sizeof(number) + sizeof(attribute length) -}+  case n of+    Attribute.VendorSpecific ->+      either (fail . ("Parse error of Vendor-Specific attribute: " ++)) pure+      $ runGet va bs+    _                     ->+      pure $ Attribute' (Standard n) bs++upacket :: Get (Attribute' v) -> Get (Packet [Attribute' v])+upacket va = packet $ many $ attribute' va+++atText :: Int -> Get AtText+atText len+  | 0 <= len && len <= 253  =  either+                               (fail . ("Get.atText: fail to decode UTF8: " ++) . show)+                               (pure . AtText . Text.unpack)+                               =<< Text.decodeUtf8' <$> getBytes len+  | len > 253               =  fail $ "Get.atText: Too long: " ++ show len+  | otherwise               =  fail $ "Get.atText: Positive length required: " ++ show len++atString :: Int -> Get AtString+atString len+  | 0 <= len && len <= 253  =  AtString <$> getBytes len+  | len > 253               =  fail $ "Get.atString: Too long: " ++ show len+  | otherwise               =  fail $ "Get.atString: Positive length required: " ++ show len++atInteger :: Get AtInteger+atInteger = AtInteger <$> getWord32be++atIpV4 :: Get AtIpV4+atIpV4 = AtIpV4 <$> getWord32be
+ src/Data/Radius/StreamGet/Monadic.hs view
@@ -0,0 +1,179 @@++module Data.Radius.StreamGet.Monadic (+  -- * DSL to get typed attributes from packet+  TypedAttributes, takeTyped', takeTyped,++  Attributes, extractAttributes,+  tellT,++  -- * low-level definitions+  AttributeGetWT, attributeGetWT, runAttributeGetWT,++  decodeAsText, decodeAsString, decodeAsInteger, decodeAsIpV4,+  ) where++import Control.Applicative ((<$>), pure, (<*), (<|>))+import Control.Monad (liftM, MonadPlus, guard, msum)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT (..))+import Control.Monad.Trans.Writer (WriterT (..), tell)+import Data.Monoid (mempty)+import Data.DList (DList)+import qualified Data.DList as DList+import qualified Data.ByteString as BS+import Data.Functor.Identity (runIdentity)+import Data.Serialize.Get (runGet)++import Data.Radius.Scalar (AtText (..), AtString (..), AtInteger (..), AtIpV4 (..))+import Data.Radius.Attribute+  (Attribute (..), Attribute' (..),+   TypedNumber, typed, value, TypedNumberSets (..), )+import qualified Data.Radius.StreamGet.Base as Base+++type AtList v at = DList (Attribute v at)+type AtWriterT v at = WriterT (AtList v at)++{-+-- May switch to simple Sum type structure+-- AIpV4 ... | AText ... | AInteger ... | AString ...+ -}++type AttributeGetWT' v m =+  AtWriterT v AtIpV4+  (AtWriterT v AtText+   (AtWriterT v AtInteger+    (AtWriterT v AtString m)))++attributeGetWT' :: m ((((a, AtList v AtIpV4), AtList v AtText), AtList v AtInteger), AtList v AtString)+                 -> AttributeGetWT' v m a+attributeGetWT' = WriterT . WriterT . WriterT . WriterT+                   {- coercible operation ^^ -}++runAttributeGetWT' :: AttributeGetWT' v m a+                    -> m ((((a, AtList v AtIpV4), AtList v AtText), AtList v AtInteger), AtList v AtString)+runAttributeGetWT' = runWriterT . runWriterT . runWriterT . runWriterT+                      {- coercible operation ^^ -}++liftAW :: Monad m => m a -> AttributeGetWT' v m a+liftAW = lift . lift . lift . lift++type AttributeGetWT v m = AttributeGetWT' v (WriterT (DList (Attribute' v)) m)+++decodeAsText :: (TypedNumberSets v, Ord v)+             => Attribute' v+             -> MaybeT (Either String) (Attribute v AtText)+decodeAsText   a@(Attribute' _ bs) = typed attributeNumbersText    (runGet . Base.atText $ BS.length bs)   a++decodeAsString :: (TypedNumberSets v, Ord v)+               => Attribute' v+               -> MaybeT (Either String) (Attribute v AtString)+decodeAsString a@(Attribute' _ bs) = typed attributeNumbersString  (runGet . Base.atString $ BS.length bs) a++decodeAsInteger :: (TypedNumberSets v, Ord v)+                => Attribute' v+                -> MaybeT (Either String) (Attribute v AtInteger)+decodeAsInteger = typed attributeNumbersInteger (runGet $ Base.atInteger <* Base.eof)++decodeAsIpV4 :: (TypedNumberSets v, Ord v)+             => Attribute' v+             -> MaybeT (Either String) (Attribute v AtIpV4)+decodeAsIpV4    = typed attributeNumbersIpV4    (runGet $ Base.atIpV4    <* Base.eof)++-- | Decode untyped attribute into monadic context.+--   When typed-value decode error found, either typed context makes sense.+tellT :: (TypedNumberSets v, Ord v)+      => Attribute' v -> AttributeGetWT v (Either String) ()+tellT a =+  let emptyW = runIdentity . runAttributeGetWT' $ pure () in+  {-- Not recoverable context type,+      AttributeGetWT' v (Writer (DList Attribute')) == AttributeGetWT v --}+  attributeGetWT' . WriterT .+  (maybe (emptyW, pure a) (\x -> (x, mempty)) <$>) . runMaybeT .  {-- un-maybe with default untyped value  --}+  runAttributeGetWT' $++  {-- recoverable context type, AttributeGetWT' (MaybeT (Either String)) --}+  do ta <- liftAW $ decodeAsString  a+     ta `seq` lift . lift . lift . tell $ pure ta+  <|>+  do ta <- liftAW $ decodeAsInteger a+     ta `seq` lift . lift . tell $ pure ta+  <|>+  do ta <- liftAW $ decodeAsText    a+     ta `seq` lift . tell $ pure ta+  <|>+  do ta <- liftAW $ decodeAsIpV4    a+     ta `seq` tell $ pure ta++attributeGetWT :: m (((((a, AtList v AtIpV4), AtList v AtText), AtList v AtInteger), AtList v AtString), DList (Attribute' v))+                 -> AttributeGetWT v m a+attributeGetWT = attributeGetWT' . WriterT++runAttributeGetWT :: AttributeGetWT v m a+                    -> m (((((a, AtList v AtIpV4), AtList v AtText), AtList v AtInteger), AtList v AtString), DList (Attribute' v))+runAttributeGetWT = runWriterT . runAttributeGetWT'+++-- | Type to express typed attribute set+data Attributes v =+  Attributes+  { textAttributes     :: ![Attribute v AtText]+  , stringAttributes   :: ![Attribute v AtString]+  , integerAttributes  :: ![Attribute v AtInteger]+  , ipV4Attributes     :: ![Attribute v AtIpV4]+  , untypedAttributes  :: ![Attribute' v]+  }++-- | Extract typed attributes.+--   For example, use like this: /extractAttributes . mapM tellT/+extractAttributes :: Monad m => AttributeGetWT v m a -> m (Attributes v)+extractAttributes w = do+  (((((_, ips), txts), ints), strs), utys)  <- runAttributeGetWT w+  return $+    Attributes+    { textAttributes     =  DList.toList txts+    , stringAttributes   =  DList.toList strs+    , integerAttributes  =  DList.toList ints+    , ipV4Attributes     =  DList.toList ips+    , untypedAttributes  =  DList.toList utys+    }++-- | Type class to generalize typed attribute param+class TypedAttributes a where+  typedAttributes :: Attributes v -> [Attribute v a]++instance TypedAttributes AtText where+  typedAttributes = textAttributes++instance TypedAttributes AtString where+  typedAttributes = stringAttributes++instance TypedAttributes AtInteger where+  typedAttributes = integerAttributes++instance TypedAttributes AtIpV4 where+  typedAttributes = ipV4Attributes++-- | Get typed attribute from attribute set.+{-# SPECIALIZE takeTyped' :: (TypedAttributes a, Eq v) => Attributes v -> TypedNumber v a -> Maybe (Attribute v a) #-}+{-# SPECIALIZE takeTyped' :: (TypedAttributes a, Eq v) => Attributes v -> TypedNumber v a -> [Attribute v a] #-}+takeTyped' :: (MonadPlus m, TypedAttributes a, Eq v)+           => Attributes v+           -> TypedNumber v a+           -> m (Attribute v a)+takeTyped' attrs tn0 =+    msum [ testA a | a <- typedAttributes attrs ]+  where+    testA a@(Attribute tn _) = do+      guard $ tn == tn0+      return a++-- | Get typed attribute value from attribute set.+{-# SPECIALIZE takeTyped :: (TypedAttributes a, Eq v) => Attributes v -> TypedNumber v a -> Maybe a #-}+{-# SPECIALIZE takeTyped :: (TypedAttributes a, Eq v) => Attributes v -> TypedNumber v a -> [a] #-}+takeTyped :: (MonadPlus m, TypedAttributes a, Eq v)+          => Attributes v+          -> TypedNumber v a+          -> m a+takeTyped attrs = liftM value . takeTyped' attrs
+ src/Data/Radius/StreamPut.hs view
@@ -0,0 +1,7 @@+module Data.Radius.StreamPut (+  module Data.Radius.StreamPut.Base,+  module Data.Radius.StreamPut.Monadic,+  ) where++import Data.Radius.StreamPut.Base+import Data.Radius.StreamPut.Monadic
+ src/Data/Radius/StreamPut/Base.hs view
@@ -0,0 +1,98 @@+module Data.Radius.StreamPut.Base (+  upacket, packet,++  header, attribute', vendorID, simpleVendorAttribute,++  code, bin128,++  atText, atString, atInteger, atIpV4,+  ) where++import Data.Word (Word8, Word32)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Serialize.Put+  (Put, putWord8, putWord16be, putWord32be,+   putByteString, runPut)++import Data.Radius.Scalar+  (Bin128, fromBin128, AtText (..), AtString (..), AtInteger (..), AtIpV4 (..))+import Data.Radius.Packet (Code, Header, Packet, codeToWord)+import qualified Data.Radius.Packet as Data+import Data.Radius.Attribute (NumberAbstract (..), Attribute' (..))+import qualified Data.Radius.Attribute as Attribute+++code :: Code -> Put+code c = putWord8 $ codeToWord c++pktId :: Word8 -> Put+pktId = putWord8++bin128 :: Bin128 -> Put+bin128 = putByteString . fromBin128++header :: Header -> Put+header h = do+  code  $ Data.code h+  pktId $ Data.pktId h+  putWord16be $ Data.pktLength h+  bin128 $ Data.authenticator h++packet :: (a -> Put) -> Packet a -> Put+packet putAttrs pkt = do+  header   $ Data.header pkt+  putAttrs $ Data.attributes pkt++radiusNumber :: Attribute.Number -> Put+radiusNumber = putWord8 . Attribute.toWord++vendorID :: Word32 -> Put+vendorID = putWord32be++simpleVendorAttribute :: Word8+                      -> ByteString+                      -> Put+simpleVendorAttribute n bs = do+  putWord8 n+  putWord8 $ fromIntegral (BS.length bs) + 2+  putByteString bs++vendorAttribute :: (a -> ByteString -> Put)+                -> a -> ByteString -> Put+vendorAttribute = id++attribute' :: (a -> ByteString -> Put)+           -> (Attribute' a) -> Put+attribute' vp (Attribute' an bs) = do+  case an of+    Standard n -> do+      radiusNumber n+      putWord8 $ fromIntegral (BS.length bs) + 2+      putByteString bs+    Vendors nn  -> do+      radiusNumber Attribute.VendorSpecific++      let bsn = runPut $ vendorAttribute vp nn bs+      putWord8 . fromIntegral $ BS.length bsn + 2  {- sizeof(number)            1+                                                    + sizeof(attribute length)  1 -}+      putByteString bsn++upacket :: (a -> ByteString -> Put)+        -> Packet [Attribute' a] -> Put+upacket vp = packet $ mapM_ $ attribute' vp+++atText :: AtText -> Put+atText (AtText t) = putByteString . Text.encodeUtf8 $ Text.pack t++atString :: AtString -> Put+atString (AtString s) = putByteString s++atInteger :: AtInteger -> Put+atInteger (AtInteger i) = putWord32be i++atIpV4 :: AtIpV4 -> Put+atIpV4 (AtIpV4 ip) = putWord32be ip
+ src/Data/Radius/StreamPut/Monadic.hs view
@@ -0,0 +1,57 @@++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 = Base.atText++instance AtValueEncode AtString where+  atValueEncode = Base.atString++instance AtValueEncode AtInteger where+  atValueEncode = Base.atInteger++instance AtValueEncode AtIpV4 where+  atValueEncode = 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 vp (Attribute n v) =+  tell . pure . Attribute' (untypeNumber n) . runPut $ vp v++attribute :: AtValueEncode a => Attribute v a -> AttributePutM v ()+attribute = exAttribute atValueEncode++-- | Add attribute key and value into monadic context+tellA :: AtValueEncode a => TypedNumber v a -> a -> AttributePutM v ()+tellA = (attribute .) . Attribute++-- | Extract attribute list from context+extractAttributes :: AttributePutM v a -> [Attribute' v]+extractAttributes w = DList.toList dl  where+  (_, dl) = runWriter w