Initial commit
This commit is contained in:
La Ancapo
commit
c101616e62
309 changed files with 53937 additions and 0 deletions
264
bundled/Network/ONCRPC/XDR/Array.hs
Normal file
264
bundled/Network/ONCRPC/XDR/Array.hs
Normal file
|
|
@ -0,0 +1,264 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
|
||||
|
||||
{- | Various kinds of arrays (lists, vectors, bytestrings) with statically
|
||||
asserted length constraints encoded in their type.
|
||||
-}
|
||||
module Network.ONCRPC.XDR.Array (
|
||||
KnownNat,
|
||||
KnownOrdering,
|
||||
LengthArray,
|
||||
FixedLengthArray,
|
||||
fixedLengthArrayLength,
|
||||
BoundedLengthArray,
|
||||
boundedLengthArrayBound,
|
||||
unLengthArray,
|
||||
unsafeLengthArray,
|
||||
lengthArray,
|
||||
lengthArray',
|
||||
boundLengthArray,
|
||||
boundLengthArrayFromList,
|
||||
padLengthArray,
|
||||
constLengthArray,
|
||||
emptyFixedLengthArray,
|
||||
emptyBoundedLengthArray,
|
||||
expandBoundedLengthArray,
|
||||
boundFixedLengthArray,
|
||||
appendLengthArray,
|
||||
fromLengthList,
|
||||
) where
|
||||
|
||||
import Prelude hiding (drop, length, replicate, take)
|
||||
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.List qualified as List
|
||||
import Data.Maybe (fromJust, fromMaybe)
|
||||
import Data.Proxy (Proxy (..))
|
||||
import Data.String (IsString (..))
|
||||
import Data.Vector qualified as V
|
||||
import Data.Word (Word8)
|
||||
import GHC.Stack (HasCallStack)
|
||||
import GHC.TypeLits (KnownNat, Nat, natVal, type CmpNat, type (+))
|
||||
|
||||
class HasLength a where
|
||||
length :: a -> Int
|
||||
|
||||
-- | Equivalent to @'compare' . 'length'@ but allows more efficient
|
||||
-- implementations
|
||||
compareLength :: a -> Int -> Ordering
|
||||
compareLength = compare . length
|
||||
|
||||
class (Monoid a, HasLength a) => Array a where
|
||||
type Elem a
|
||||
take :: Int -> a -> a
|
||||
replicate :: Int -> Elem a -> a
|
||||
fromList :: [Elem a] -> a
|
||||
|
||||
instance HasLength [a] where
|
||||
length = List.length
|
||||
compareLength [] n = compare 0 n
|
||||
compareLength (_ : l) n = compareLength l (n - 1)
|
||||
instance Array [a] where
|
||||
type Elem [a] = a
|
||||
take = List.take
|
||||
replicate = List.replicate
|
||||
fromList = id
|
||||
|
||||
instance HasLength (V.Vector a) where
|
||||
length = V.length
|
||||
instance Array (V.Vector a) where
|
||||
type Elem (V.Vector a) = a
|
||||
take = V.take
|
||||
replicate = V.replicate
|
||||
fromList = V.fromList
|
||||
|
||||
instance HasLength BS.ByteString where
|
||||
length = BS.length
|
||||
instance Array BS.ByteString where
|
||||
type Elem BS.ByteString = Word8
|
||||
take = BS.take
|
||||
replicate = BS.replicate
|
||||
fromList = BS.pack
|
||||
|
||||
instance HasLength BSL.ByteString where
|
||||
length = fromIntegral . BSL.length
|
||||
compareLength b n
|
||||
| BSL.null b' = LT
|
||||
| BSL.null (BSL.tail b') = EQ
|
||||
| otherwise = GT
|
||||
where
|
||||
b' = BSL.drop (fromIntegral n - 1) b
|
||||
instance Array BSL.ByteString where
|
||||
type Elem BSL.ByteString = Word8
|
||||
take = BSL.take . fromIntegral
|
||||
replicate = BSL.replicate . fromIntegral
|
||||
fromList = BSL.pack
|
||||
|
||||
class KnownOrdering (o :: Ordering) where
|
||||
orderingVal :: proxy o -> Ordering
|
||||
|
||||
instance KnownOrdering 'LT where orderingVal _ = LT
|
||||
instance KnownOrdering 'EQ where orderingVal _ = EQ
|
||||
instance KnownOrdering 'GT where orderingVal _ = GT
|
||||
|
||||
-- | Assertion that the contained array satisfies @'compareLength' a n = o@
|
||||
newtype LengthArray (o :: Ordering) (n :: Nat) a
|
||||
= LengthArray {unLengthArray :: a}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance (HasLength a) => HasLength (LengthArray o n a) where
|
||||
length = length . unLengthArray
|
||||
compareLength = compareLength . unLengthArray
|
||||
|
||||
-- | Assertion that the contained array is exactly a static length
|
||||
type FixedLengthArray n a = LengthArray 'EQ n a
|
||||
|
||||
-- | Assertion that the contained array is at most a static length (inclusive)
|
||||
type BoundedLengthArray n a = LengthArray 'LT (n + 1) a
|
||||
|
||||
lengthArrayOrdering ::
|
||||
forall o n a. (KnownOrdering o) => LengthArray o n a -> Ordering
|
||||
lengthArrayOrdering _ = orderingVal (Proxy :: Proxy o)
|
||||
|
||||
lengthArrayBound :: forall o n a. (KnownNat n) => LengthArray o n a -> Int
|
||||
lengthArrayBound _ = fromInteger $ natVal (Proxy :: Proxy n)
|
||||
|
||||
orderingOp :: Ordering -> Char
|
||||
orderingOp LT = '<'
|
||||
orderingOp EQ = '='
|
||||
orderingOp GT = '>'
|
||||
|
||||
describeLengthArray ::
|
||||
(KnownOrdering o, KnownNat n) => LengthArray o n a -> String
|
||||
describeLengthArray a =
|
||||
orderingOp (lengthArrayOrdering a) : show (lengthArrayBound a)
|
||||
|
||||
-- | Static length of a 'FixedLengthArray'
|
||||
fixedLengthArrayLength :: (KnownNat n) => LengthArray 'EQ n a -> Int
|
||||
fixedLengthArrayLength = lengthArrayBound
|
||||
|
||||
-- | Static upper-bound (inclusive) of a 'BoundedLengthArray'
|
||||
boundedLengthArrayBound :: (KnownNat n) => LengthArray 'LT n a -> Int
|
||||
boundedLengthArrayBound = subtract 1 . lengthArrayBound
|
||||
|
||||
{- | Unsafely create a 'LengthArray' without checking the length bound
|
||||
assertion. May cause unpredictable behavior if the bound does not hold.
|
||||
-}
|
||||
unsafeLengthArray :: a -> LengthArray o n a
|
||||
unsafeLengthArray = LengthArray
|
||||
|
||||
checkLengthArray ::
|
||||
(KnownOrdering o, KnownNat n, HasLength a) => LengthArray o n a -> Bool
|
||||
checkLengthArray l@(LengthArray a) =
|
||||
compareLength a (lengthArrayBound l) == lengthArrayOrdering l
|
||||
|
||||
{- | Safely create a 'LengthArray' out of an array if it conforms to the static
|
||||
length assertion.
|
||||
-}
|
||||
lengthArray ::
|
||||
forall o n a.
|
||||
(KnownOrdering o, KnownNat n, HasLength a) =>
|
||||
a ->
|
||||
Maybe (LengthArray o n a)
|
||||
lengthArray a
|
||||
| checkLengthArray l = Just l
|
||||
| otherwise = Nothing
|
||||
where
|
||||
l = LengthArray a :: LengthArray o n a
|
||||
|
||||
{- | Create a 'LengthArray' or runtime error if the assertion fails:
|
||||
@fromMaybe undefined . 'lengthArray'@
|
||||
-}
|
||||
lengthArray' ::
|
||||
forall o n a.
|
||||
(HasCallStack, KnownOrdering o, KnownNat n, HasLength a) =>
|
||||
a ->
|
||||
LengthArray o n a
|
||||
lengthArray' a =
|
||||
fromMaybe
|
||||
(error $ "lengthArray': fails check " ++ describeLengthArray (fromJust la))
|
||||
la
|
||||
where
|
||||
la = lengthArray a
|
||||
|
||||
-- | Create a 'BoundedLengthArray' by trimming the given array if necessary.
|
||||
boundLengthArray :: (KnownNat n, Array a) => a -> LengthArray 'LT n a
|
||||
boundLengthArray a = l
|
||||
where
|
||||
l = LengthArray $ take (boundedLengthArrayBound l) a
|
||||
|
||||
-- | Create a 'BoundedLengthArray' by trimming the given array if necessary.
|
||||
boundLengthArrayFromList ::
|
||||
(KnownNat n, Array a) => [Elem a] -> LengthArray 'LT n a
|
||||
boundLengthArrayFromList a = l
|
||||
where
|
||||
l = LengthArray $ fromList $ take (boundedLengthArrayBound l) a
|
||||
|
||||
{- | Create a 'FixedLengthArray' by trimming or padding (on the right)
|
||||
as necessary.
|
||||
-}
|
||||
padLengthArray :: (KnownNat n, Array a) => a -> Elem a -> LengthArray 'EQ n a
|
||||
padLengthArray a p = l
|
||||
where
|
||||
a' = case compareLength a n of
|
||||
LT -> a <> replicate (n - length a) p
|
||||
EQ -> a
|
||||
GT -> take n a
|
||||
n = fixedLengthArrayLength l
|
||||
l = LengthArray a'
|
||||
|
||||
-- | Create a 'FixedLengthArray' filled with the same value.
|
||||
constLengthArray :: (KnownNat n, Array a) => Elem a -> LengthArray 'EQ n a
|
||||
constLengthArray p = l
|
||||
where
|
||||
l = LengthArray $ replicate (fixedLengthArrayLength l) p
|
||||
|
||||
instance
|
||||
(KnownOrdering o, KnownNat n, IsString a, HasLength a) =>
|
||||
IsString (LengthArray o n a)
|
||||
where
|
||||
fromString s =
|
||||
fromMaybe
|
||||
( error $
|
||||
"String "
|
||||
++ show s
|
||||
++ " fails LengthArray check "
|
||||
++ describeLengthArray (fromJust ls)
|
||||
)
|
||||
ls
|
||||
where
|
||||
ls = lengthArray $ fromString s
|
||||
|
||||
-- | An empty 'FixedLengthArray'.
|
||||
emptyFixedLengthArray :: (Array a) => LengthArray 'EQ 0 a
|
||||
emptyFixedLengthArray = LengthArray mempty
|
||||
|
||||
-- | An empty 'BoundedLengthArray'.
|
||||
emptyBoundedLengthArray :: (CmpNat 0 n ~ 'LT, Array a) => LengthArray 'LT n a
|
||||
emptyBoundedLengthArray = LengthArray mempty
|
||||
|
||||
-- | Grow the bound of a 'BoundedLengthArray'.
|
||||
expandBoundedLengthArray ::
|
||||
(CmpNat n m ~ 'LT) => LengthArray 'LT n a -> LengthArray 'LT m a
|
||||
expandBoundedLengthArray = LengthArray . unLengthArray
|
||||
|
||||
-- | Convert a 'FixedLengthArray' to a 'BoundedLengthArray'.
|
||||
boundFixedLengthArray ::
|
||||
(CmpNat n m ~ 'LT) => LengthArray 'EQ n a -> LengthArray 'LT m a
|
||||
boundFixedLengthArray = LengthArray . unLengthArray
|
||||
|
||||
-- | Append to two 'LengthArray's.
|
||||
appendLengthArray ::
|
||||
(Monoid a) =>
|
||||
LengthArray o n a ->
|
||||
LengthArray o m a ->
|
||||
LengthArray o (n + m) a
|
||||
appendLengthArray (LengthArray a) (LengthArray b) = LengthArray $ mappend a b
|
||||
|
||||
fromLengthList :: (Array a) => LengthArray o n [Elem a] -> LengthArray o n a
|
||||
fromLengthList = LengthArray . fromList . unLengthArray
|
||||
61
bundled/Network/ONCRPC/XDR/Cabal.hs
Normal file
61
bundled/Network/ONCRPC/XDR/Cabal.hs
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
-- | Cabal utilities for XDR processing.
|
||||
module Network.ONCRPC.XDR.Cabal
|
||||
( ppRPCGenSuffixHandler
|
||||
) where
|
||||
|
||||
import Data.Char (toLower)
|
||||
import Data.Coerce
|
||||
import Data.List (intercalate, isPrefixOf)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Distribution.PackageDescription (BuildInfo(customFieldsBI))
|
||||
import Distribution.Verbosity (Verbosity)
|
||||
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, ComponentLocalBuildInfo)
|
||||
import Distribution.Simple.PreProcess (PreProcessor(..), PPSuffixHandler, Suffix(..))
|
||||
import Distribution.Simple.Utils (info)
|
||||
import System.FilePath ((</>), dropExtension, splitDirectories)
|
||||
|
||||
import Network.ONCRPC.XDR.Generate
|
||||
|
||||
runRPCGen :: [(String, String)] -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO ()
|
||||
runRPCGen custom (indir, infile) (outdir, outfile) verb = do
|
||||
info verb $ "hdrpcgen " ++ inpath ++ " with " ++ show opts
|
||||
writeFile outpath
|
||||
=<< generateFromFile opts inpath
|
||||
where
|
||||
opts = GenerateOptions
|
||||
{ generateModuleName = modname
|
||||
, generateReidentOptions = ReidentOptions
|
||||
{ reidentUpperPrefix = fromMaybe "" $ opt "upper-prefix"
|
||||
, reidentLowerPrefix = fromMaybe "" $ opt "lower-prefix"
|
||||
, reidentJoinField = joinopt "field"
|
||||
, reidentJoinProcedure = joinopt "procedure"
|
||||
}
|
||||
}
|
||||
joinopt t = case (maybe False boolish $ opt $ t ++ "s-unique", opt $ "join-" ++ t) of
|
||||
(False, j) -> Just $ fromMaybe "'" j
|
||||
(True, Nothing) -> Nothing
|
||||
(True, Just _) ->
|
||||
error "x-rpcgen join and unique options are mutually exclusive"
|
||||
boolish s = map toLower s `isPrefixOf` "true"
|
||||
opt f = lookup f custom
|
||||
inpath = indir </> infile
|
||||
outpath = outdir </> outfile
|
||||
modname = intercalate "." $ splitDirectories $ dropExtension infile
|
||||
|
||||
ppRPCGenCustomField :: (String, String) -> Maybe (String, String)
|
||||
ppRPCGenCustomField ('x':'-':'r':'p':'c':'g':'e':'n':'-':f,v) = Just (f,v)
|
||||
ppRPCGenCustomField _ = Nothing
|
||||
|
||||
ppRPCGen :: BuildInfo -> LocalBuildInfo -> ComponentLocalBuildInfo -> PreProcessor
|
||||
ppRPCGen bi _ _ = PreProcessor
|
||||
{ platformIndependent = True
|
||||
, runPreProcessor = runRPCGen $ mapMaybe ppRPCGenCustomField $ customFieldsBI bi
|
||||
, ppOrdering = undefined
|
||||
}
|
||||
|
||||
-- |Pre-processor for hsrpcgen.
|
||||
-- You can use it by setting @'Distribution.Simple.UserHooks' { 'Distribution.Simple.hookedPrepProcessors' = ['ppRPCGenSuffixHandler'] }@.
|
||||
-- Note that this will override the default alex @.x@ file handler.
|
||||
-- You can also specify custom cabal fields corresponding to 'ReidentOptions' and command-line flags prefixed with @x-rpcgen-@: @{upper,lower}-prefix@, @join-{field,procedure}@, and @{field,procedure}s-unique}@.
|
||||
ppRPCGenSuffixHandler :: PPSuffixHandler
|
||||
ppRPCGenSuffixHandler = (coerce "x", ppRPCGen)
|
||||
306
bundled/Network/ONCRPC/XDR/Generate.hs
Normal file
306
bundled/Network/ONCRPC/XDR/Generate.hs
Normal file
|
|
@ -0,0 +1,306 @@
|
|||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | Generate Haskell code from XDR descriptions as per RFC4506 and RPC extensions from RFC5531
|
||||
module Network.ONCRPC.XDR.Generate
|
||||
( generateFromFile
|
||||
, generate
|
||||
, generateModule
|
||||
, ReidentOptions(..)
|
||||
, GenerateOptions(..)
|
||||
, defaultReidentOptions
|
||||
) where
|
||||
|
||||
import Control.Arrow ((***), (&&&))
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSLC
|
||||
import Data.Char (isAlpha, isUpper)
|
||||
import Data.Maybe (fromMaybe, maybeToList)
|
||||
import qualified Language.Haskell.Exts.Build as HS
|
||||
import Language.Haskell.Exts.Pretty (prettyPrintWithMode, PPHsMode(..), defaultMode)
|
||||
import qualified Language.Haskell.Exts.Syntax as HS
|
||||
|
||||
import qualified Network.ONCRPC.XDR as XDR
|
||||
import Network.ONCRPC.XDR.Specification
|
||||
import qualified Network.ONCRPC.XDR.Parse as XDR
|
||||
import Network.ONCRPC.XDR.Reident
|
||||
|
||||
name :: String -> HS.Name ()
|
||||
name "" = error "empty name"
|
||||
name s@(c:_)
|
||||
| isAlpha c || c == '_' = HS.Ident () s
|
||||
| otherwise = HS.Symbol () s
|
||||
|
||||
infix 9 !, !.
|
||||
(!) :: String -> String -> HS.QName ()
|
||||
(!) "" = HS.UnQual () . name
|
||||
(!) m = HS.Qual () (HS.ModuleName () m) . name
|
||||
|
||||
(!.) :: String -> String -> HS.Exp ()
|
||||
_ !. [] = error "empty qualified name"
|
||||
m !. n@(c:_)
|
||||
| isUpper c || c == ':' = HS.Con () $ m ! n
|
||||
| otherwise = HS.Var () $ m ! n
|
||||
|
||||
instDecl :: HS.QName () -> String -> [HS.InstDecl ()] -> HS.Decl ()
|
||||
instDecl c t = HS.InstDecl () Nothing
|
||||
(HS.IRule () Nothing Nothing $ HS.IHApp () (HS.IHCon () c) $ HS.TyCon () $ ""!t)
|
||||
. Just
|
||||
|
||||
dataDecl :: String -> [HS.ConDecl ()] -> [String] -> HS.Decl ()
|
||||
dataDecl n con derive = HS.DataDecl () (HS.DataType ()) Nothing (HS.DHead () $ HS.name n)
|
||||
(map (HS.QualConDecl () Nothing Nothing) con)
|
||||
[HS.Deriving () Nothing $ map (HS.IRule () Nothing Nothing . HS.IHCon () . ("Prelude"!)) derive]
|
||||
|
||||
constantType :: HS.Type ()
|
||||
constantType = HS.TyForall ()
|
||||
Nothing
|
||||
( Just $
|
||||
HS.CxSingle () $
|
||||
HS.TypeA () (HS.TyApp () (HS.TyCon () ("Prelude"!"Integral")) t)
|
||||
)
|
||||
t
|
||||
where
|
||||
t = HS.TyVar () $ HS.name "a"
|
||||
|
||||
primType :: TypeSpecifier -> Maybe String
|
||||
primType TypeInt = Just "Int"
|
||||
primType TypeUnsignedInt = Just "UnsignedInt"
|
||||
primType TypeHyper = Just "Hyper"
|
||||
primType TypeUnsignedHyper = Just "UnsignedHyper"
|
||||
primType TypeFloat = Just "Float"
|
||||
primType TypeDouble = Just "Double"
|
||||
primType TypeQuadruple = Just "Quadruple"
|
||||
primType TypeBool = Just "Bool"
|
||||
primType _ = Nothing
|
||||
|
||||
specType :: TypeSpecifier -> Maybe (HS.Type ())
|
||||
specType (TypeIdentifier t) = Just $ HS.TyCon () $ ""!t
|
||||
specType t = HS.TyCon () . (!) "XDR" <$> primType t
|
||||
|
||||
specType' :: TypeSpecifier -> HS.Type ()
|
||||
specType' =
|
||||
fromMaybe (error "parameter data structures are not supported") . specType
|
||||
|
||||
lengthType :: String -> XDR.Length -> HS.Type ()
|
||||
lengthType t l = HS.TyApp () (HS.TyCon () $ "XDR"!t) $ HS.TyPromoted () $ HS.PromotedInteger () (toInteger l) (show l)
|
||||
|
||||
descrType :: TypeDescriptor -> Maybe (HS.Type ())
|
||||
descrType (TypeSingle t) = specType t
|
||||
descrType (TypeArray t (FixedLength l)) = HS.TyApp () (lengthType "FixedArray" l) <$> specType t
|
||||
descrType (TypeArray t (VariableLength l)) = HS.TyApp () (lengthType "Array" l) <$> specType t
|
||||
descrType (TypeOpaque (FixedLength l)) = Just $ lengthType "FixedOpaque" l
|
||||
descrType (TypeOpaque (VariableLength l)) = Just $ lengthType "Opaque" l
|
||||
descrType (TypeString (FixedLength l)) = Just $ lengthType "FixedString" l
|
||||
descrType (TypeString (VariableLength l)) = Just $ lengthType "String" l
|
||||
descrType (TypeOptional t) = HS.TyApp () (HS.TyCon () $ "XDR"!"Optional") <$> specType t
|
||||
|
||||
declType' :: Declaration -> HS.Type ()
|
||||
declType' (Declaration n t) = fromMaybe (error $ "nested data structures are not supported: " ++ show n) $ descrType t
|
||||
|
||||
strictType :: HS.Type () -> HS.Type ()
|
||||
strictType = HS.TyBang () (HS.BangedTy ()) (HS.NoUnpackPragma ())
|
||||
|
||||
declaration :: Declaration -> [HS.FieldDecl ()]
|
||||
declaration (Declaration _ (TypeSingle (TypeStruct (StructBody dl)))) =
|
||||
concatMap declaration dl
|
||||
declaration d@(Declaration i _) =
|
||||
[HS.FieldDecl () [HS.name i] $ strictType $ declType' d]
|
||||
|
||||
optionalDeclaration :: OptionalDeclaration -> [HS.FieldDecl ()]
|
||||
optionalDeclaration = foldMap declaration
|
||||
|
||||
typeDef :: String -> HS.Decl ()
|
||||
typeDef = HS.simpleFun (HS.name "xdrType") (HS.name "_") . HS.strE
|
||||
|
||||
fieldNames :: [HS.FieldDecl ()] -> [HS.Name ()]
|
||||
fieldNames = concatMap $ \(HS.FieldDecl _ nl _) -> nl
|
||||
|
||||
putFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
|
||||
putFields _ [] = HS.app ("Control.Applicative"!."pure") (HS.Con () $ HS.Special () $ HS.UnitCon ())
|
||||
putFields x l = foldl1 (flip HS.infixApp $ HS.QVarOp () $ "Control.Applicative"!"*>")
|
||||
$ map (HS.app ("XDR"!."xdrPut") . flip HS.app x . HS.var)
|
||||
$ fieldNames l
|
||||
|
||||
getFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp ()
|
||||
getFields n = foldl (\c _ -> HS.infixApp c (HS.QVarOp () $ "Control.Applicative"!"<*>") $ "XDR"!."xdrGet") n . fieldNames
|
||||
|
||||
pureCon :: String -> HS.Exp ()
|
||||
pureCon = HS.app ("Control.Applicative"!."pure") . HS.Con () . (""!)
|
||||
|
||||
sMatch :: String -> HS.Pat () -> HS.Exp () -> HS.Match ()
|
||||
sMatch n p e = HS.Match () (HS.name n) [p] (HS.UnGuardedRhs () e) Nothing
|
||||
|
||||
definition :: Definition -> [HS.Decl ()]
|
||||
definition (Definition n (TypeDef (TypeSingle (TypeEnum (EnumBody el))))) =
|
||||
[ dataDecl n
|
||||
(map (flip (HS.ConDecl ()) [] . HS.name . fst) el)
|
||||
["Eq", "Ord", "Enum", "Bounded", "Show"]
|
||||
, instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
|
||||
[ typeDef n
|
||||
, HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutEnum"
|
||||
, HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetEnum"
|
||||
]
|
||||
, instDecl ("XDR"!"XDREnum") n $ map (HS.InsDecl ())
|
||||
[ HS.FunBind () $ map (\(i,v) ->
|
||||
sMatch "xdrFromEnum" (HS.pApp (HS.name i) []) $ HS.intE $ toInteger v)
|
||||
el
|
||||
, HS.FunBind () $ map (\(i,v) ->
|
||||
sMatch "xdrToEnum" (HS.intP $ toInteger v) $ HS.app ("Prelude"!."return") $ HS.Con () $ ""!i)
|
||||
el ++
|
||||
[ sMatch "xdrToEnum" (HS.PWildCard ()) $ HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n]
|
||||
]
|
||||
]
|
||||
definition (Definition n (TypeDef (TypeSingle (TypeStruct (StructBody dl))))) =
|
||||
[ dataDecl n
|
||||
[HS.RecDecl () (HS.name n) hdl]
|
||||
["Eq", "Show"]
|
||||
, instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
|
||||
[ typeDef n
|
||||
, HS.simpleFun (HS.name "xdrPut") (HS.name "_x") $ putFields (HS.var $ HS.name "_x") hdl
|
||||
, HS.nameBind (HS.name "xdrGet") $ getFields (pureCon n) hdl
|
||||
]
|
||||
] where
|
||||
hdl = concatMap declaration dl
|
||||
definition (Definition n (TypeDef (TypeSingle (TypeUnion (UnionBody d@(Declaration dn _) cl o))))) =
|
||||
[ dataDecl n
|
||||
(map (\(_,(l,b)) ->
|
||||
HS.RecDecl () (HS.name l) b) hcl
|
||||
++ maybe [] (\(l,b) -> [HS.RecDecl () (HS.name l)
|
||||
$ HS.FieldDecl () [HS.name hom] (strictType hdt) : b])
|
||||
ho)
|
||||
["Eq", "Show"]
|
||||
, HS.TypeSig () [HS.name dn] $ HS.TyFun () (HS.TyCon () $ ""!n) hdt
|
||||
, HS.nameBind (HS.name dn) $ "XDR"!."xdrDiscriminant"
|
||||
, instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ())
|
||||
[ typeDef n
|
||||
, HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutUnion"
|
||||
, HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetUnion"
|
||||
]
|
||||
, instDecl ("XDR"!"XDRUnion") n
|
||||
[ HS.InsType () (HS.TyApp () (HS.TyCon () $ ""!"XDRDiscriminant") (HS.TyCon () $ ""!n)) hdt
|
||||
, HS.InsDecl () $ HS.FunBind () $ map
|
||||
(uncurry (split [] . HS.intE))
|
||||
hcl
|
||||
++ maybeToList (split
|
||||
[HS.PFieldPat () (""!hom) (HS.pvar $ HS.name "d")]
|
||||
(HS.app ("XDR"!."xdrFromEnum") (""!."d"))
|
||||
<$> ho)
|
||||
, HS.InsDecl () $ HS.FunBind () $ map (\(c,(l,b)) ->
|
||||
sMatch "xdrGetUnionArm"
|
||||
(HS.intP c)
|
||||
$ getFields (pureCon l) b)
|
||||
hcl
|
||||
++ [sMatch "xdrGetUnionArm"
|
||||
(HS.pvar $ HS.name "_c")
|
||||
$ maybe
|
||||
(HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n ++ " discriminant")
|
||||
(\(l,b) -> getFields (HS.infixApp (HS.Con () $ ""!l) (HS.QVarOp () $ "Control.Applicative"!"<$>")
|
||||
(HS.app ("XDR"!."xdrToEnum") $ HS.var $ HS.name "_c")) b)
|
||||
ho]
|
||||
]
|
||||
] where
|
||||
split p c (l,b) = sMatch "xdrSplitUnion"
|
||||
(HS.PAsPat () (HS.name "_x") $ HS.PRec () (""!l) p)
|
||||
$ HS.tuple [c, putFields (""!."_x") b]
|
||||
hdt = declType' d
|
||||
hcl = map (toInteger *** arm) cl
|
||||
hom = dn ++ "'"
|
||||
ho = arm <$> o
|
||||
arm = unionCaseIdentifier &&& optionalDeclaration . unionDeclaration
|
||||
definition (Definition n (TypeDef t)) =
|
||||
[ HS.TypeDecl () (HS.DHead () $ HS.name n) $ declType' (Declaration n t)
|
||||
]
|
||||
definition (Definition n (Constant v)) =
|
||||
[ HS.TypeSig () [HS.name n] constantType
|
||||
, HS.nameBind (HS.name n) $ HS.intE v
|
||||
]
|
||||
definition (Definition n (Program t vl px)) =
|
||||
[ HS.TypeSig () [HS.name n] $ HS.TyCon () $ ""!t
|
||||
, HS.nameBind (HS.name n) $ HS.appFun (""!.t) $ map (\(Version _ vt rl vx) ->
|
||||
HS.appFun (""!.vt) $ map (\(Procedure _ _ _ rx) ->
|
||||
HS.appFun ("RPC"!."Procedure") $ map (HS.intE . toInteger) [px, vx, rx])
|
||||
rl)
|
||||
vl
|
||||
, dataDecl t [HS.RecDecl () (HS.name t) (map (\(Version vn vt _ _) ->
|
||||
HS.FieldDecl () [HS.name vn] $ strictType $ HS.TyCon () $ ""!vt)
|
||||
vl)] []
|
||||
] ++ map (\(Version _ vt rl _) ->
|
||||
dataDecl vt [HS.RecDecl () (HS.name vt) (map (\(Procedure rr rn ra _) ->
|
||||
HS.FieldDecl () [HS.name rn]
|
||||
$ strictType $ HS.TyApp () (HS.TyApp () (HS.TyCon () $ "RPC"!"Procedure")
|
||||
$ tt $ map specType' ra)
|
||||
$ maybe (HS.unit_tycon ()) specType' rr)
|
||||
rl)] []
|
||||
) vl
|
||||
where
|
||||
tt [] = HS.unit_tycon ()
|
||||
tt [a] = a
|
||||
tt l = HS.TyTuple () HS.Boxed l
|
||||
|
||||
hasProgramDefinition :: Specification -> Bool
|
||||
hasProgramDefinition = any isProgramDefinition where
|
||||
isProgramDefinition (Definition _ Program{}) = True
|
||||
isProgramDefinition _ = False
|
||||
|
||||
specification :: String -> Specification -> HS.Module ()
|
||||
specification specName specContent =
|
||||
HS.Module
|
||||
()
|
||||
(Just $ HS.ModuleHead () (HS.ModuleName () specName) Nothing Nothing)
|
||||
[HS.LanguagePragma () $ map HS.name ["DataKinds", "TypeFamilies"]]
|
||||
( [ importDecl "Prelude" Nothing
|
||||
, importDecl "Control.Applicative" Nothing
|
||||
, importDecl "Network.ONCRPC.XDR" $ Just $ HS.ModuleName () "XDR"
|
||||
]
|
||||
++
|
||||
[ importDecl "Network.ONCRPC.Types" $ Just $ HS.ModuleName () "RPC"
|
||||
| hasProgramDefinition specContent
|
||||
]
|
||||
)
|
||||
(concatMap definition specContent)
|
||||
where
|
||||
importDecl importModule importAs =
|
||||
HS.ImportDecl
|
||||
{ importAnn = ()
|
||||
, importModule = HS.ModuleName () importModule
|
||||
, importQualified = True
|
||||
, importSrc = False
|
||||
, importSafe = False
|
||||
, importPkg = Nothing
|
||||
, importAs
|
||||
, importSpecs = Nothing
|
||||
}
|
||||
|
||||
-- |Options for generating Haskell code
|
||||
data GenerateOptions = GenerateOptions
|
||||
{ generateModuleName :: String -- ^Name for the generated module
|
||||
, generateReidentOptions :: ReidentOptions
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- |Parse an XDR specification and generate a Haskell module, or fail on error.
|
||||
-- The 'String' argument provides a description of the input to use in parse errors.
|
||||
generateModule :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ())
|
||||
generateModule GenerateOptions{..} n b = do
|
||||
(d, s) <- either (fail . show) return $ XDR.parse n b
|
||||
return $ specification generateModuleName $ reident generateReidentOptions s d
|
||||
|
||||
-- |Parse an XDR specification and generate pretty-printed Haskell source string, or fail on error.
|
||||
-- The 'String' argument provides a description of the input to use in parse errors.
|
||||
generate :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m String
|
||||
generate opts n s = do
|
||||
m <- generateModule opts n s
|
||||
return $ "-- |Generated from " ++ n ++ " by <https://github.com/dylex/haskell-nfs/tree/master/rpc hsrpcgen>\n"
|
||||
++ prettyPrintWithMode defaultMode
|
||||
{ classIndent = 2
|
||||
, doIndent = 2
|
||||
, multiIfIndent = 2
|
||||
, caseIndent = 2
|
||||
, letIndent = 2
|
||||
, whereIndent = 2
|
||||
, onsideIndent = 2
|
||||
} m
|
||||
|
||||
-- |'generate' from a file.
|
||||
generateFromFile :: GenerateOptions -> FilePath -> IO String
|
||||
generateFromFile opts f = generate opts f =<< BSLC.readFile f
|
||||
42
bundled/Network/ONCRPC/XDR/Opaque.hs
Normal file
42
bundled/Network/ONCRPC/XDR/Opaque.hs
Normal file
|
|
@ -0,0 +1,42 @@
|
|||
-- |Marshalling values into and out of 'Network.ONCRPC.XDR.Types.Opaque' byte strings.
|
||||
-- Not really part of XDR, but convenient way to avoid many conversion functions.
|
||||
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
module Network.ONCRPC.XDR.Opaque
|
||||
( Opaqued(..)
|
||||
, unopacify'
|
||||
, toOpaque
|
||||
, toOpaque'
|
||||
, fromOpaque
|
||||
, fromOpaque'
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
|
||||
import Network.ONCRPC.XDR.Array
|
||||
import Network.ONCRPC.XDR.Serial
|
||||
|
||||
-- |Values that can be stored in an 'Network.ONCRPC.XDR.Types.Opaque' 'ByteString'.
|
||||
-- The default implementation allows (re-)embedding of XDR-encoded data, such as with 'RPC.Opaque_auth'.
|
||||
class Opaqued a where
|
||||
opacify :: a -> ByteString
|
||||
default opacify :: XDR a => a -> ByteString
|
||||
opacify = xdrSerialize
|
||||
unopacify :: MonadFail m => ByteString -> m a
|
||||
default unopacify :: (XDR a, MonadFail m) => ByteString -> m a
|
||||
unopacify = either fail return . xdrDeserialize
|
||||
|
||||
unopacify' :: Opaqued a => ByteString -> a
|
||||
unopacify' = either error id . unopacify
|
||||
|
||||
toOpaque :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> Maybe (LengthArray o n ByteString)
|
||||
toOpaque = lengthArray . opacify
|
||||
|
||||
toOpaque' :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> LengthArray o n ByteString
|
||||
toOpaque' = lengthArray' . opacify
|
||||
|
||||
fromOpaque :: (Opaqued a, MonadFail m) => LengthArray o n ByteString -> m a
|
||||
fromOpaque = unopacify . unLengthArray
|
||||
|
||||
fromOpaque' :: Opaqued a => LengthArray o n ByteString -> a
|
||||
fromOpaque' = unopacify' . unLengthArray
|
||||
307
bundled/Network/ONCRPC/XDR/Parse.hs
Normal file
307
bundled/Network/ONCRPC/XDR/Parse.hs
Normal file
|
|
@ -0,0 +1,307 @@
|
|||
-- | XDR Parser for .x files, as per RFC4506 and RPC extensions from RFC5531
|
||||
module Network.ONCRPC.XDR.Parse
|
||||
( Binding(..)
|
||||
, Scope
|
||||
, parse
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Arrow (second)
|
||||
import Control.Monad (void, join, liftM2)
|
||||
import qualified Data.ByteString.Lazy as BSL
|
||||
import Data.Char (digitToInt, isLower, isUpper, toLower, toUpper)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Maybe (catMaybes, mapMaybe)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Text.Parsec as P
|
||||
import Text.Parsec ((<?>))
|
||||
import qualified Text.Parsec.Token as PT
|
||||
|
||||
import qualified Network.ONCRPC.XDR.Types as XDR
|
||||
import Network.ONCRPC.XDR.Specification hiding (arrayLength)
|
||||
|
||||
data Binding = Binding
|
||||
{ bindingInitCaseConflict :: !Bool -- ^Same name as another identifier modulo first character case
|
||||
, bindingDefinition :: !DefinitionBody
|
||||
}
|
||||
|
||||
type Scope = Map.Map String Binding
|
||||
type Stream = BSL.ByteString
|
||||
type Parser = P.Parsec Stream Scope
|
||||
|
||||
tupleM :: Monad m => m a -> m b -> m (a, b)
|
||||
tupleM = liftM2 (,)
|
||||
|
||||
baseScope :: Scope
|
||||
baseScope =
|
||||
Map.fromList $
|
||||
( "bool"
|
||||
, Binding False $ TypeDef $ TypeSingle $ TypeEnum $ EnumBody boolValues
|
||||
)
|
||||
: map (second (Binding False . TypeDef . TypeSingle))
|
||||
[ ("int", TypeInt)
|
||||
, ("unsigned", TypeUnsignedInt)
|
||||
, ("hyper", TypeHyper)
|
||||
, ("float", TypeFloat)
|
||||
, ("double", TypeDouble)
|
||||
, ("quadruple", TypeQuadruple)
|
||||
]
|
||||
++ map (second $ Binding False . Constant . toInteger) boolValues
|
||||
|
||||
toggleCase :: String -> String
|
||||
toggleCase (c:s)
|
||||
| isUpper c = toLower c:s
|
||||
| isLower c = toUpper c:s
|
||||
toggleCase s = s
|
||||
|
||||
addScope :: Definition -> Parser ()
|
||||
addScope (Definition i b) = do
|
||||
case b of
|
||||
TypeDef t -> void $ resolveTypeDescriptor t
|
||||
_ -> return ()
|
||||
s <- P.getState
|
||||
case Map.insertLookupWithKey (const const) i (Binding (Map.member (toggleCase i) s) b) s of
|
||||
(Nothing, s') -> P.putState s'
|
||||
_ -> fail $ "duplicate identifier: " ++ show i
|
||||
|
||||
checkInt :: (MonadFail m, Integral n) => Integer -> m n
|
||||
checkInt n
|
||||
| n == toInteger n' = return n'
|
||||
| otherwise = fail "invalid constant"
|
||||
where n' = fromInteger n
|
||||
|
||||
data Value
|
||||
= ValueIdentifier !String
|
||||
| ValueConstant !Integer
|
||||
deriving (Show)
|
||||
|
||||
resolveValue :: Integral n => Value -> Parser n
|
||||
resolveValue (ValueConstant n) = checkInt n
|
||||
resolveValue (ValueIdentifier v) = do
|
||||
s <- P.getState
|
||||
case Map.lookup v s of
|
||||
Just (Binding _ (Constant n)) -> checkInt n
|
||||
_ -> fail $ "undefined constant: " ++ show v
|
||||
|
||||
-- |Expand 'TypeSingle' 'TypeIdentifier'
|
||||
resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor
|
||||
resolveTypeDescriptor (TypeSingle (TypeIdentifier i)) = do
|
||||
s <- P.getState
|
||||
case Map.lookup i s of
|
||||
Just (Binding _ (TypeDef t)) -> resolveTypeDescriptor t
|
||||
_ -> fail $ "undefined type: " ++ show i
|
||||
resolveTypeDescriptor d = return d
|
||||
|
||||
literalLetter :: Parser Char
|
||||
literalLetter = P.alphaNum <|> P.char '_'
|
||||
|
||||
token :: PT.GenTokenParser Stream Scope Identity
|
||||
token = PT.makeTokenParser PT.LanguageDef
|
||||
{ PT.commentStart = "/*"
|
||||
, PT.commentEnd = "*/"
|
||||
, PT.commentLine = "//"
|
||||
, PT.nestedComments = False
|
||||
, PT.identStart = P.letter
|
||||
, PT.identLetter = literalLetter
|
||||
, PT.opStart = fail "token op"
|
||||
, PT.opLetter = fail "token op"
|
||||
, PT.reservedNames =
|
||||
[ "bool"
|
||||
, "case"
|
||||
, "const"
|
||||
, "default"
|
||||
, "double"
|
||||
, "quadruple"
|
||||
, "enum"
|
||||
, "float"
|
||||
, "hyper"
|
||||
, "int"
|
||||
, "opaque"
|
||||
, "string"
|
||||
, "struct"
|
||||
, "switch"
|
||||
, "typedef"
|
||||
, "union"
|
||||
, "unsigned"
|
||||
, "void"
|
||||
|
||||
, "program"
|
||||
, "version"
|
||||
]
|
||||
, PT.reservedOpNames = []
|
||||
, PT.caseSensitive = True
|
||||
}
|
||||
|
||||
reserved :: String -> Parser ()
|
||||
reserved = PT.reserved token
|
||||
|
||||
identifier :: Parser String
|
||||
identifier = PT.identifier token
|
||||
|
||||
endSemi1 :: Parser a -> Parser [a]
|
||||
endSemi1 p = p `P.endBy1` PT.semi token
|
||||
|
||||
arrayLength, variableArrayLength :: Parser ArrayLength
|
||||
variableArrayLength =
|
||||
VariableLength <$> PT.angles token (P.option XDR.maxLength value)
|
||||
arrayLength =
|
||||
FixedLength <$> PT.brackets token value
|
||||
<|> variableArrayLength
|
||||
|
||||
declaration :: Parser Declaration
|
||||
declaration =
|
||||
typeDeclaration
|
||||
<|> opaqueDeclaration
|
||||
<|> stringDeclaration
|
||||
where
|
||||
typeDeclaration = do
|
||||
t <- typeSpecifier
|
||||
Declaration
|
||||
<$> (PT.symbol token "*" *> identifier)
|
||||
<*> pure (TypeOptional t)
|
||||
<|> Declaration
|
||||
<$> identifier
|
||||
<*> (TypeArray t <$> arrayLength <|> return (TypeSingle t))
|
||||
opaqueDeclaration =
|
||||
Declaration
|
||||
<$> (reserved "opaque" *> identifier)
|
||||
<*> (TypeOpaque <$> arrayLength)
|
||||
stringDeclaration =
|
||||
Declaration
|
||||
<$> (reserved "string" *> identifier)
|
||||
<*> (TypeString <$> variableArrayLength)
|
||||
|
||||
optionalDeclaration :: Parser OptionalDeclaration
|
||||
optionalDeclaration =
|
||||
Just <$> declaration
|
||||
<|> Nothing <$ reserved "void"
|
||||
|
||||
constant :: Parser Integer
|
||||
constant =
|
||||
PT.lexeme token (nat <|> P.char '-' *> (negate <$> dec)) <?> "constant"
|
||||
where
|
||||
nat = P.char '0' *> (P.oneOf "xX" *> number 16 P.hexDigit <|> number 8 P.octDigit <|> return 0) <|> dec
|
||||
dec = number 10 P.digit
|
||||
number base digit = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> P.many1 digit
|
||||
|
||||
value :: Integral n => Parser n
|
||||
value = resolveValue =<<
|
||||
ValueConstant <$> constant
|
||||
<|> ValueIdentifier <$> identifier
|
||||
|
||||
typeSpecifier :: Parser TypeSpecifier
|
||||
typeSpecifier = P.choice
|
||||
[ TypeInt <$ reserved "int"
|
||||
, TypeHyper <$ reserved "hyper"
|
||||
, reserved "unsigned" *> (
|
||||
TypeUnsignedInt <$ reserved "int"
|
||||
<|> TypeUnsignedHyper <$ reserved "hyper"
|
||||
<|> return TypeUnsignedInt)
|
||||
, TypeFloat <$ reserved "float"
|
||||
, TypeDouble <$ reserved "double"
|
||||
, TypeQuadruple <$ reserved "quadruple"
|
||||
, TypeBool <$ reserved "bool"
|
||||
, reserved "enum" *> (TypeEnum <$> enumBody <|> typeIdentifier)
|
||||
, reserved "struct"*> (TypeStruct <$> structBody <|> typeIdentifier)
|
||||
, reserved "union" *> (TypeUnion <$> unionBody <|> typeIdentifier)
|
||||
, typeIdentifier
|
||||
] where
|
||||
typeIdentifier = TypeIdentifier <$> identifier
|
||||
|
||||
checkUnique :: (Ord k, Show k) => String -> [k] -> Parser (Set.Set k)
|
||||
checkUnique t = ui Set.empty where
|
||||
ui m [] = return m
|
||||
ui m (k:l)
|
||||
| Set.member k m = fail $ "duplicate " ++ t ++ ": " ++ show k
|
||||
| otherwise = ui (Set.insert k m) l
|
||||
|
||||
enumBody :: Parser EnumBody
|
||||
enumBody = do
|
||||
l <- PT.braces token $ PT.commaSep1 token $
|
||||
tupleM identifier (PT.symbol token "=" *> value)
|
||||
_ <- checkUnique "enum identifier" $ fst <$> l
|
||||
_ <- checkUnique "enum value" $ snd <$> l
|
||||
mapM_ (\(i, v) -> addScope $ Definition i $ Constant $ toInteger v) l
|
||||
return $ EnumBody l
|
||||
|
||||
structBody :: Parser StructBody
|
||||
structBody = do
|
||||
l <- PT.braces token $ catMaybes <$> endSemi1 optionalDeclaration
|
||||
_ <- checkUnique "struct member" $ declarationIdentifier <$> l
|
||||
return $ StructBody l
|
||||
|
||||
unionBody :: Parser UnionBody
|
||||
unionBody = do
|
||||
reserved "switch"
|
||||
d <- PT.parens token declaration
|
||||
r <- resolveTypeDescriptor $ declarationType d
|
||||
p <- case r of
|
||||
TypeSingle TypeInt -> return value
|
||||
TypeSingle TypeUnsignedInt -> return $ fromIntegral <$> (value :: Parser XDR.UnsignedInt)
|
||||
TypeSingle TypeBool -> return $ valid boolValues =<< value
|
||||
TypeSingle (TypeEnum (EnumBody v)) -> return $ valid v =<< value
|
||||
_ -> fail "invalid discriminant declaration"
|
||||
PT.braces token $ do
|
||||
l <- endSemi1 (tupleM
|
||||
(P.many1 $ reserved "case" *> tupleM (P.lookAhead $ P.many1 literalLetter) p <* PT.colon token)
|
||||
optionalDeclaration)
|
||||
_ <- checkUnique "union member" $ mapMaybe (fmap declarationIdentifier . snd) l
|
||||
_ <- checkUnique "union case" $ map snd . fst =<< l
|
||||
f <- P.optionMaybe $ UnionArm "default" <$> (reserved "default" *> PT.colon token *> optionalDeclaration <* PT.semi token)
|
||||
return $ UnionBody d [ (c, UnionArm s b) | (cs, b) <- l, (s, c) <- cs ] f
|
||||
where
|
||||
valid l n
|
||||
| any ((n ==) . snd) l = return n
|
||||
| otherwise = fail "invalid enum value"
|
||||
|
||||
procedure :: Parser Procedure
|
||||
procedure = Procedure
|
||||
<$> optionalType
|
||||
<*> identifier
|
||||
<*> PT.parens token (catMaybes <$> PT.commaSep1 token optionalType)
|
||||
<*> (PT.symbol token "=" *> value)
|
||||
where
|
||||
optionalType :: Parser (Maybe TypeSpecifier)
|
||||
optionalType =
|
||||
Just <$> typeSpecifier
|
||||
<|> Nothing <$ reserved "void"
|
||||
|
||||
programVersion :: Parser Version
|
||||
programVersion = join Version
|
||||
<$> (reserved "version" *> identifier)
|
||||
<*> PT.braces token (endSemi1 procedure)
|
||||
<*> (PT.symbol token "=" *> value)
|
||||
|
||||
def :: Parser Definition
|
||||
def = constantDef <|> typeDef <|> programDef where
|
||||
constantDef = Definition
|
||||
<$> (reserved "const" *> identifier)
|
||||
<*> (PT.symbol token "=" *> (Constant <$> constant))
|
||||
typeDef =
|
||||
reserved "typedef" *> (declDef <$> declaration)
|
||||
<|> Definition <$> (reserved "enum" *> identifier) <*> (TypeDef . TypeSingle . TypeEnum <$> enumBody)
|
||||
<|> Definition <$> (reserved "struct" *> identifier) <*> (TypeDef . TypeSingle . TypeStruct <$> structBody)
|
||||
<|> Definition <$> (reserved "union" *> identifier) <*> (TypeDef . TypeSingle . TypeUnion <$> unionBody)
|
||||
declDef (Declaration i t) = Definition i $ TypeDef t
|
||||
programDef = do
|
||||
reserved "program"
|
||||
i <- identifier
|
||||
Definition i <$> (Program i
|
||||
<$> PT.braces token (endSemi1 programVersion)
|
||||
<*> (PT.symbol token "=" *> value))
|
||||
|
||||
definition :: Parser Definition
|
||||
definition = do
|
||||
d <- def
|
||||
addScope d
|
||||
return d
|
||||
|
||||
specification :: Parser Specification
|
||||
specification = endSemi1 definition
|
||||
|
||||
file :: Parser (Specification, Scope)
|
||||
file = PT.whiteSpace token *> tupleM specification P.getState <* P.eof
|
||||
|
||||
parse :: String -> BSL.ByteString -> Either P.ParseError (Specification, Scope)
|
||||
parse = P.runParser file baseScope
|
||||
108
bundled/Network/ONCRPC/XDR/Reident.hs
Normal file
108
bundled/Network/ONCRPC/XDR/Reident.hs
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
-- |Convert XDR identifiers to Haskell identifiers.
|
||||
-- Rules to convert identifiers in a 'Specification' to follow Haskell's lexical rules and ensure uniqueness for Haskell's scoping.
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Network.ONCRPC.XDR.Reident
|
||||
( ReidentOptions(..)
|
||||
, defaultReidentOptions
|
||||
, reident
|
||||
) where
|
||||
|
||||
import Control.Arrow (first, second)
|
||||
import Data.Char (isLower, isUpper, toLower, toUpper)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Network.ONCRPC.XDR.Specification
|
||||
import qualified Network.ONCRPC.XDR.Parse as XDR
|
||||
|
||||
-- |How to generate Haskell identifiers from XDR in order to confirm to Haskell's lexical rules and ensure uniqueness.
|
||||
data ReidentOptions = ReidentOptions
|
||||
{ reidentUpperPrefix, reidentLowerPrefix :: String -- ^Prefix to use to make an identifier a different case if necessary, e.g. @\"_\"@ for lower-case, or @\"XDR_\"@ for upper case (default empty: just changes the first character, possibly resulting in names like @\"nFS_NULL\"@)
|
||||
, reidentJoinField, reidentJoinProcedure :: Maybe String -- ^Prefix fields with their type name (or program, version name) and this string (necessary for most XDR files), or @Nothing@ to use only the field name (or procedure name), which assumes uniqueness across the file (e.g., if you wrote the file yourself, though often safe for procedures only) (default @Just \"\'\"@)
|
||||
}
|
||||
deriving (Eq, Show)
|
||||
|
||||
defaultReidentOptions :: ReidentOptions
|
||||
defaultReidentOptions = ReidentOptions
|
||||
{ reidentUpperPrefix = ""
|
||||
, reidentLowerPrefix = ""
|
||||
, reidentJoinField = Just "'"
|
||||
, reidentJoinProcedure = Just "'"
|
||||
}
|
||||
|
||||
data ReidentOps = ReidentOps
|
||||
{ reidentUpper, reidentLower :: String -> String
|
||||
, reidentField, reidentProcedure :: String -> String -> String
|
||||
, reidentUnique :: String -> String
|
||||
}
|
||||
|
||||
reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps
|
||||
reidentOps ReidentOptions{..} scope = ReidentOps
|
||||
{ reidentUpper = toUpperPrefix reidentUpperPrefix
|
||||
, reidentLower = toLowerPrefix reidentLowerPrefix
|
||||
, reidentField = joinField reidentJoinField
|
||||
, reidentProcedure = joinField reidentJoinProcedure
|
||||
, reidentUnique = unique
|
||||
} where
|
||||
toUpperPrefix _ "" = error "empty upper prefix"
|
||||
toUpperPrefix p s@(h:t)
|
||||
| isUpper h = s
|
||||
| null p = toUpper h : t
|
||||
| otherwise = p ++ s
|
||||
toLowerPrefix _ "" = error "empty lower prefix"
|
||||
toLowerPrefix p s@(h:t)
|
||||
| isLower h = s
|
||||
| null p = toLower h : t
|
||||
| otherwise = p ++ s
|
||||
joinField (Just c) p n = p ++ c ++ n
|
||||
joinField Nothing _ n = n
|
||||
unique n
|
||||
| Set.member n dups = n ++ "'"
|
||||
| otherwise = n
|
||||
dups = Map.keysSet $ Map.filter XDR.bindingInitCaseConflict scope
|
||||
|
||||
declaration :: ReidentOps -> String -> Declaration -> Declaration
|
||||
declaration ops n (Declaration m t) = Declaration (reidentLower ops nm) (typeDescriptor ops nm t) where
|
||||
nm = reidentField ops n m
|
||||
|
||||
typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier
|
||||
typeSpecifier ops _ (TypeEnum (EnumBody el)) = TypeEnum $
|
||||
EnumBody $ map (first $ reidentUnique ops) el
|
||||
typeSpecifier ops n (TypeStruct (StructBody dl)) = TypeStruct $
|
||||
StructBody $ map (declaration ops n) dl
|
||||
typeSpecifier ops n (TypeUnion (UnionBody d cl o)) = TypeUnion $
|
||||
UnionBody (decl d) (map (second arm) cl) (arm <$> o) where
|
||||
arm (UnionArm l m) = UnionArm (con l) (decl <$> m)
|
||||
con l = reidentUpper ops $ n ++ '\'' : l
|
||||
decl = declaration ops n
|
||||
typeSpecifier ops _ (TypeIdentifier i) = TypeIdentifier $
|
||||
reidentUpper ops $ reidentUnique ops i
|
||||
typeSpecifier _ _ t = t
|
||||
|
||||
typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor
|
||||
typeDescriptor ops n (TypeSingle t) = TypeSingle (typeSpecifier ops n t)
|
||||
typeDescriptor ops n (TypeArray t l) = TypeArray (typeSpecifier ops n t) l
|
||||
typeDescriptor ops n (TypeOptional t) = TypeOptional (typeSpecifier ops n t)
|
||||
typeDescriptor _ _ t = t
|
||||
|
||||
procedure :: ReidentOps -> String -> Procedure -> Procedure
|
||||
procedure ops n (Procedure r m al x) = Procedure (ts <$> r) (reidentLower ops nm) (ts <$> al) x where
|
||||
nm = reidentProcedure ops n m
|
||||
ts = typeSpecifier ops nm
|
||||
|
||||
version :: ReidentOps -> String -> Version -> Version
|
||||
version ops n (Version m t pl x) = Version (reidentLower ops nm) (reidentUpper ops nt) (map (procedure ops nm) pl) x where
|
||||
nm = reidentProcedure ops n m
|
||||
nt = reidentProcedure ops n t
|
||||
|
||||
makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition
|
||||
makeDefinition ops n (TypeDef d) = Definition (reidentUpper ops n) $ TypeDef $ typeDescriptor ops n d
|
||||
makeDefinition ops n (Program t vl x) = Definition (reidentLower ops n) $ Program (reidentUpper ops t) (map (version ops n) vl) x
|
||||
makeDefinition ops n b@(Constant _) = Definition (reidentLower ops n) b
|
||||
|
||||
definition :: ReidentOps -> Definition -> Definition
|
||||
definition ops (Definition n d) = makeDefinition ops (reidentUnique ops n) d
|
||||
|
||||
reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification
|
||||
reident o = map . definition . reidentOps o
|
||||
|
||||
291
bundled/Network/ONCRPC/XDR/Serial.hs
Normal file
291
bundled/Network/ONCRPC/XDR/Serial.hs
Normal file
|
|
@ -0,0 +1,291 @@
|
|||
{-# OPTIONS -Wno-orphans #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
|
||||
-- | XDR Serialization
|
||||
module Network.ONCRPC.XDR.Serial (
|
||||
XDR (..),
|
||||
XDREnum (..),
|
||||
xdrToEnum',
|
||||
xdrPutEnum,
|
||||
xdrGetEnum,
|
||||
XDRUnion (..),
|
||||
xdrDiscriminant,
|
||||
xdrPutUnion,
|
||||
xdrGetUnion,
|
||||
xdrSerialize,
|
||||
xdrSerializeLazy,
|
||||
xdrDeserialize,
|
||||
xdrDeserializeLazy,
|
||||
) where
|
||||
|
||||
import Control.Monad (guard, replicateM, unless)
|
||||
import Data.ByteString qualified as BS
|
||||
import Data.ByteString.Lazy qualified as BSL
|
||||
import Data.Maybe (fromJust, listToMaybe)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Serialize (Get, Put)
|
||||
import Data.Serialize qualified as Serialize
|
||||
import Data.Vector (Vector)
|
||||
import Data.Vector qualified as Vector
|
||||
import GHC.TypeLits (natVal)
|
||||
import Network.ONCRPC.XDR.Types qualified as XDR
|
||||
|
||||
import Network.ONCRPC.XDR.Array
|
||||
|
||||
instance MonadFail (Either String) where
|
||||
fail = Left
|
||||
|
||||
-- | An XDR type that can be (de)serialized.
|
||||
class XDR a where
|
||||
-- | XDR identifier/type descriptor; argument value is ignored.
|
||||
xdrType :: a -> String
|
||||
|
||||
xdrPut :: a -> Put
|
||||
|
||||
xdrGet :: Get a
|
||||
|
||||
instance XDR XDR.Int where
|
||||
xdrType _ = "int"
|
||||
xdrPut = Serialize.putInt32be
|
||||
xdrGet = Serialize.getInt32be
|
||||
|
||||
instance XDR XDR.UnsignedInt where
|
||||
xdrType _ = "unsigned int"
|
||||
xdrPut = Serialize.putWord32be
|
||||
xdrGet = Serialize.getWord32be
|
||||
|
||||
instance XDR XDR.Hyper where
|
||||
xdrType _ = "hyper"
|
||||
xdrPut = Serialize.putInt64be
|
||||
xdrGet = Serialize.getInt64be
|
||||
|
||||
instance XDR XDR.UnsignedHyper where
|
||||
xdrType _ = "unsigned hyper"
|
||||
xdrPut = Serialize.putWord64be
|
||||
xdrGet = Serialize.getWord64be
|
||||
|
||||
instance XDR XDR.Float where
|
||||
xdrType _ = "float"
|
||||
xdrPut = Serialize.putFloat32be
|
||||
xdrGet = Serialize.getFloat32be
|
||||
|
||||
instance XDR XDR.Double where
|
||||
xdrType _ = "double"
|
||||
xdrPut = Serialize.putFloat64be
|
||||
xdrGet = Serialize.getFloat64be
|
||||
|
||||
instance XDR XDR.Bool where
|
||||
xdrType _ = "bool"
|
||||
xdrPut = xdrPutEnum
|
||||
xdrGet = xdrGetEnum
|
||||
|
||||
{- | An XDR type defined with \"enum\".
|
||||
Note that the 'XDREnum' 'XDR.Int' value is not (necessarily) the same as the 'Enum' 'Int' value.
|
||||
The 'Enum' instance is derived automatically to allow 'succ', etc. to work usefully in Haskell, whereas the 'XDREnum' reflects the XDR-defined values.
|
||||
-}
|
||||
class (XDR a, Enum a) => XDREnum a where
|
||||
xdrFromEnum :: a -> XDR.Int
|
||||
xdrToEnum :: (MonadFail m) => XDR.Int -> m a
|
||||
|
||||
instance XDREnum XDR.Int where
|
||||
xdrFromEnum = id
|
||||
xdrToEnum = pure
|
||||
|
||||
instance XDREnum XDR.UnsignedInt where
|
||||
xdrFromEnum = fromIntegral
|
||||
xdrToEnum = pure . fromIntegral
|
||||
|
||||
-- | Version of 'xdrToEnum' that fails at runtime for invalid values: @fromMaybe undefined . 'xdrToEnum'@.
|
||||
xdrToEnum' :: (XDREnum a) => XDR.Int -> a
|
||||
xdrToEnum' = either error id . xdrToEnum
|
||||
|
||||
-- | Default implementation of 'xdrPut' for 'XDREnum'.
|
||||
xdrPutEnum :: (XDREnum a) => a -> Put
|
||||
xdrPutEnum = Serialize.put . xdrFromEnum
|
||||
|
||||
-- | Default implementation of 'xdrGet' for 'XDREnum'.
|
||||
xdrGetEnum :: (XDREnum a) => Get a
|
||||
xdrGetEnum = xdrToEnum =<< Serialize.get
|
||||
|
||||
instance XDREnum XDR.Bool where
|
||||
xdrFromEnum False = 0
|
||||
xdrFromEnum True = 1
|
||||
xdrToEnum 0 = pure False
|
||||
xdrToEnum 1 = pure True
|
||||
xdrToEnum _ = fail "invalid bool"
|
||||
|
||||
-- | An XDR type defined with \"union\"
|
||||
class (XDR a, XDREnum (XDRDiscriminant a)) => XDRUnion a where
|
||||
type XDRDiscriminant a
|
||||
|
||||
-- | Split a union into its discriminant and body generator.
|
||||
xdrSplitUnion :: a -> (XDR.Int, Put)
|
||||
|
||||
-- | Get the body of a union based on its discriminant.
|
||||
xdrGetUnionArm :: XDR.Int -> Get a
|
||||
|
||||
xdrDiscriminant :: (XDRUnion a) => a -> XDRDiscriminant a
|
||||
xdrDiscriminant = xdrToEnum' . fst . xdrSplitUnion
|
||||
|
||||
-- | Default implementation of 'xdrPut' for 'XDRUnion'.
|
||||
xdrPutUnion :: (XDRUnion a) => a -> Put
|
||||
xdrPutUnion = uncurry ((>>) . xdrPut) . xdrSplitUnion
|
||||
|
||||
-- | Default implementation of 'xdrGet' for 'XDRUnion'.
|
||||
xdrGetUnion :: (XDRUnion a) => Get a
|
||||
xdrGetUnion = xdrGet >>= xdrGetUnionArm
|
||||
|
||||
instance (XDR a) => XDR (XDR.Optional a) where
|
||||
xdrType = ('*' :) . xdrType . fromJust
|
||||
xdrPut = xdrPutUnion
|
||||
xdrGet = xdrGetUnion
|
||||
|
||||
instance (XDR a) => XDRUnion (XDR.Optional a) where
|
||||
type XDRDiscriminant (XDR.Optional a) = XDR.Bool
|
||||
xdrSplitUnion Nothing = (0, pure ())
|
||||
xdrSplitUnion (Just a) = (1, xdrPut a)
|
||||
xdrGetUnionArm 0 = pure Nothing
|
||||
xdrGetUnionArm 1 = Just <$> xdrGet
|
||||
xdrGetUnionArm d = fail $ "xdrGetUnion: invalid discriminant for " ++ xdrType (undefined :: XDR.Optional a) ++ ": " ++ show d
|
||||
|
||||
xdrPutPad :: XDR.Length -> Put
|
||||
xdrPutPad n = case n `mod` 4 of
|
||||
0 -> pure ()
|
||||
1 -> Serialize.putWord16host 0 >> Serialize.putWord8 0
|
||||
2 -> Serialize.putWord16host 0
|
||||
_ {- must be 3 -} -> Serialize.putWord8 0
|
||||
|
||||
xdrGetPad :: XDR.Length -> Get ()
|
||||
xdrGetPad n = case n `mod` 4 of
|
||||
0 -> pure ()
|
||||
1 -> do
|
||||
0 <- Serialize.getWord16host
|
||||
0 <- Serialize.getWord8
|
||||
pure ()
|
||||
2 -> do
|
||||
0 <- Serialize.getWord16host
|
||||
pure ()
|
||||
_ {- must be 3 -} -> do
|
||||
0 <- Serialize.getWord8
|
||||
pure ()
|
||||
|
||||
bsLength :: BS.ByteString -> XDR.Length
|
||||
bsLength = fromIntegral . BS.length
|
||||
|
||||
xdrPutByteString :: XDR.Length -> BS.ByteString -> Put
|
||||
xdrPutByteString l b = do
|
||||
unless (bsLength b == l) $ error "xdrPutByteString: incorrect length"
|
||||
Serialize.putByteString b
|
||||
xdrPutPad l
|
||||
|
||||
xdrGetByteString :: XDR.Length -> Get BS.ByteString
|
||||
xdrGetByteString l = do
|
||||
b <- Serialize.getByteString $ fromIntegral l
|
||||
xdrGetPad l
|
||||
pure b
|
||||
|
||||
fixedLength :: forall n a. (KnownNat n) => LengthArray 'EQ n a -> String -> String
|
||||
fixedLength a = (++ ('[' : show (fixedLengthArrayLength a) ++ "]"))
|
||||
|
||||
variableLength :: forall n a. (KnownNat n) => LengthArray 'LT n a -> String -> String
|
||||
variableLength a
|
||||
| n == XDR.maxLength = (++ "<>")
|
||||
| otherwise = (++ ('<' : show n ++ ">"))
|
||||
where
|
||||
n = fromIntegral $ boundedLengthArrayBound a
|
||||
|
||||
xdrGetBoundedArray :: forall n a. (KnownNat n) => (XDR.Length -> Get a) -> Get (LengthArray 'LT n a)
|
||||
xdrGetBoundedArray g = do
|
||||
l <- xdrGet
|
||||
guard $ l <= fromIntegral (boundedLengthArrayBound (undefined :: LengthArray 'LT n a))
|
||||
unsafeLengthArray <$> g l
|
||||
|
||||
instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n [a]) where
|
||||
xdrType la =
|
||||
fixedLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la
|
||||
xdrPut la = mapM_ xdrPut a where a = unLengthArray la
|
||||
xdrGet =
|
||||
unsafeLengthArray <$> replicateM (fromInteger $ natVal $ Proxy @n) xdrGet
|
||||
|
||||
instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n [a]) where
|
||||
xdrType la =
|
||||
variableLength la $ xdrType $ fromJust $ listToMaybe $ unLengthArray la
|
||||
xdrPut la = do
|
||||
xdrPut (fromIntegral (length a) :: XDR.Length)
|
||||
mapM_ xdrPut a
|
||||
where
|
||||
a = unLengthArray la
|
||||
xdrGet = xdrGetBoundedArray $ \l -> replicateM (fromIntegral l) xdrGet
|
||||
|
||||
instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n (Vector a)) where
|
||||
xdrType la = fixedLength la $ xdrType $ Vector.head $ unLengthArray la
|
||||
xdrPut la = mapM_ xdrPut a where a = unLengthArray la
|
||||
xdrGet =
|
||||
unsafeLengthArray
|
||||
<$> Vector.replicateM (fromInteger $ natVal $ Proxy @n) xdrGet
|
||||
|
||||
instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n (Vector a)) where
|
||||
xdrType la = variableLength la $ xdrType $ Vector.head $ unLengthArray la
|
||||
xdrPut la = do
|
||||
xdrPut (fromIntegral (length a) :: XDR.Length)
|
||||
mapM_ xdrPut a
|
||||
where
|
||||
a = unLengthArray la
|
||||
xdrGet = xdrGetBoundedArray $ \l -> Vector.replicateM (fromIntegral l) xdrGet
|
||||
|
||||
instance (KnownNat n) => XDR (LengthArray 'EQ n BS.ByteString) where
|
||||
xdrType o = fixedLength o "opaque"
|
||||
xdrPut o =
|
||||
xdrPutByteString (fromInteger $ natVal $ Proxy @n) $ unLengthArray o
|
||||
xdrGet =
|
||||
unsafeLengthArray <$> xdrGetByteString (fromInteger $ natVal $ Proxy @n)
|
||||
|
||||
instance (KnownNat n) => XDR (LengthArray 'LT n BS.ByteString) where
|
||||
xdrType o = variableLength o "opaque"
|
||||
xdrPut o = do
|
||||
xdrPut l
|
||||
xdrPutByteString l b
|
||||
where
|
||||
l = bsLength b
|
||||
b = unLengthArray o
|
||||
xdrGet = xdrGetBoundedArray xdrGetByteString
|
||||
|
||||
instance XDR () where
|
||||
xdrType () = "void"
|
||||
xdrPut () = pure ()
|
||||
xdrGet = pure ()
|
||||
|
||||
instance (XDR a, XDR b) => XDR (a, b) where
|
||||
xdrType (a, b) = xdrType a ++ '+' : xdrType b
|
||||
xdrPut (a, b) = xdrPut a >> xdrPut b
|
||||
xdrGet = (,) <$> xdrGet <*> xdrGet
|
||||
|
||||
instance (XDR a, XDR b, XDR c) => XDR (a, b, c) where
|
||||
xdrType (a, b, c) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c
|
||||
xdrPut (a, b, c) = xdrPut a >> xdrPut b >> xdrPut c
|
||||
xdrGet = (,,) <$> xdrGet <*> xdrGet <*> xdrGet
|
||||
|
||||
instance (XDR a, XDR b, XDR c, XDR d) => XDR (a, b, c, d) where
|
||||
xdrType (a, b, c, d) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c ++ '+' : xdrType d
|
||||
xdrPut (a, b, c, d) = xdrPut a >> xdrPut b >> xdrPut c >> xdrPut d
|
||||
xdrGet = (,,,) <$> xdrGet <*> xdrGet <*> xdrGet <*> xdrGet
|
||||
|
||||
xdrSerialize :: (XDR a) => a -> BS.ByteString
|
||||
xdrSerialize = Serialize.runPut . xdrPut
|
||||
|
||||
xdrSerializeLazy :: (XDR a) => a -> BSL.ByteString
|
||||
xdrSerializeLazy = Serialize.runPutLazy . xdrPut
|
||||
|
||||
-- | @"S.runGet' 'xdrGet'@
|
||||
xdrDeserialize :: (XDR a) => BS.ByteString -> Either String a
|
||||
xdrDeserialize = Serialize.runGet xdrGet
|
||||
|
||||
-- | @"S.runGetLazy' 'xdrGet'@
|
||||
xdrDeserializeLazy :: (XDR a) => BSL.ByteString -> Either String a
|
||||
xdrDeserializeLazy = Serialize.runGetLazy xdrGet
|
||||
111
bundled/Network/ONCRPC/XDR/Specification.hs
Normal file
111
bundled/Network/ONCRPC/XDR/Specification.hs
Normal file
|
|
@ -0,0 +1,111 @@
|
|||
-- |XDR specification, as per RFC4506 and RPC extensions from RFC5531
|
||||
|
||||
module Network.ONCRPC.XDR.Specification
|
||||
where
|
||||
|
||||
import qualified Network.ONCRPC.XDR.Types as XDR
|
||||
import Data.Word (Word32)
|
||||
|
||||
type ProgNum = Word32
|
||||
type VersNum = Word32
|
||||
type ProcNum = Word32
|
||||
|
||||
data ArrayLength
|
||||
= FixedLength { arrayLength :: !XDR.Length }
|
||||
| VariableLength { arrayLength :: !XDR.Length -- ^defaulted to maxLength
|
||||
}
|
||||
|
||||
data TypeDescriptor
|
||||
= TypeSingle
|
||||
{ descriptorType :: !TypeSpecifier
|
||||
}
|
||||
| TypeArray
|
||||
{ descriptorType :: !TypeSpecifier
|
||||
, descriptorLength :: !ArrayLength
|
||||
}
|
||||
| TypeOpaque
|
||||
{ descriptorLength :: !ArrayLength
|
||||
}
|
||||
| TypeString
|
||||
{ descriptorLength :: !ArrayLength -- ^only 'VariableArray'
|
||||
}
|
||||
| TypeOptional
|
||||
{ descriptorType :: !TypeSpecifier
|
||||
}
|
||||
|
||||
data TypeSpecifier
|
||||
= TypeInt
|
||||
| TypeUnsignedInt
|
||||
| TypeHyper
|
||||
| TypeUnsignedHyper
|
||||
| TypeFloat
|
||||
| TypeDouble
|
||||
| TypeQuadruple
|
||||
| TypeBool
|
||||
| TypeEnum !EnumBody
|
||||
| TypeStruct !StructBody
|
||||
| TypeUnion !UnionBody
|
||||
| TypeIdentifier !String
|
||||
|
||||
-- |Non-void declaration
|
||||
data Declaration = Declaration
|
||||
{ declarationIdentifier :: !String
|
||||
, declarationType :: TypeDescriptor
|
||||
}
|
||||
|
||||
-- |'Declaration' or void
|
||||
type OptionalDeclaration = Maybe Declaration
|
||||
|
||||
type EnumValues = [(String, XDR.Int)]
|
||||
|
||||
newtype EnumBody = EnumBody
|
||||
{ enumValues :: EnumValues
|
||||
}
|
||||
|
||||
boolValues :: EnumValues
|
||||
boolValues = [("FALSE", 0), ("TRUE", 1)]
|
||||
|
||||
newtype StructBody = StructBody
|
||||
{ structMembers :: [Declaration] -- ^with voids elided
|
||||
}
|
||||
|
||||
data UnionArm = UnionArm
|
||||
{ unionCaseIdentifier :: String -- ^The literal string found after "case", for labeling
|
||||
, unionDeclaration :: OptionalDeclaration
|
||||
}
|
||||
|
||||
data UnionBody = UnionBody
|
||||
{ unionDiscriminant :: !Declaration
|
||||
, unionCases :: [(XDR.Int, UnionArm)]
|
||||
, unionDefault :: Maybe UnionArm
|
||||
}
|
||||
|
||||
data Procedure = Procedure
|
||||
{ procedureRes :: Maybe TypeSpecifier
|
||||
, procedureIdentifier :: !String
|
||||
, procedureArgs :: [TypeSpecifier]
|
||||
, procedureNumber :: !ProcNum
|
||||
}
|
||||
|
||||
data Version = Version
|
||||
{ versionIdentifier :: !String
|
||||
, versionTypeIdentifier :: !String
|
||||
, versionProcedures :: [Procedure]
|
||||
, versionNumber :: !VersNum
|
||||
}
|
||||
|
||||
data DefinitionBody
|
||||
= TypeDef TypeDescriptor
|
||||
| Constant Integer
|
||||
| Program
|
||||
{ programTypeIdentifier :: !String
|
||||
, programVersions :: [Version]
|
||||
, programNumber :: !ProgNum
|
||||
}
|
||||
|
||||
data Definition = Definition
|
||||
{ definitionIdentifier :: !String
|
||||
, definitionBody :: !DefinitionBody
|
||||
}
|
||||
|
||||
type Specification = [Definition]
|
||||
55
bundled/Network/ONCRPC/XDR/Types.hs
Normal file
55
bundled/Network/ONCRPC/XDR/Types.hs
Normal file
|
|
@ -0,0 +1,55 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
|
||||
-- | XDR Types.
|
||||
-- The 'Quadruple' type is not supported as there is no reasonable Haskell equivalent.
|
||||
--
|
||||
-- This module should be imported qualified, e.g., as @XDR@.
|
||||
module Network.ONCRPC.XDR.Types
|
||||
( Int
|
||||
, UnsignedInt
|
||||
, Hyper
|
||||
, UnsignedHyper
|
||||
, Float
|
||||
, Double
|
||||
, Bool
|
||||
, FixedArray
|
||||
, Array
|
||||
, FixedOpaque
|
||||
, Opaque
|
||||
, FixedString
|
||||
, String
|
||||
, Optional
|
||||
|
||||
, Length
|
||||
, maxLength
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude hiding (Int, String)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Int (Int32, Int64)
|
||||
import Data.Vector (Vector)
|
||||
import Data.Word (Word32, Word64)
|
||||
|
||||
import Network.ONCRPC.XDR.Array
|
||||
|
||||
type Int = Int32
|
||||
type UnsignedInt = Word32
|
||||
type Hyper = Int64
|
||||
type UnsignedHyper = Word64
|
||||
type FixedArray n a = FixedLengthArray n (Vector a)
|
||||
type Array n a = BoundedLengthArray n (Vector a)
|
||||
type FixedOpaque n = FixedLengthArray n ByteString
|
||||
type Opaque n = BoundedLengthArray n ByteString
|
||||
type FixedString n = FixedLengthArray n ByteString
|
||||
type String n = BoundedLengthArray n ByteString
|
||||
type Optional a = Maybe a
|
||||
|
||||
-- |Not a real XDR type, but used for length headers
|
||||
type Length = UnsignedInt
|
||||
|
||||
maxLength :: Length
|
||||
maxLength = maxBound
|
||||
Loading…
Add table
Add a link
Reference in a new issue