{-# LANGUAGE RankNTypes, FlexibleContexts, ScopedTypeVariables #-}
module Text.ProtocolBuffers.ProtoCompile.Resolve(loadProto,loadCodeGenRequest,makeNameMaps,getTLS,getPackageID
,Env(..),TopLevel(..),ReMap,NameMap(..),PackageID(..),LocalFP(..),CanonFP(..)) where
import qualified Text.DescriptorProtos.DescriptorProto as D(DescriptorProto)
import qualified Text.DescriptorProtos.DescriptorProto as D.DescriptorProto(DescriptorProto(..))
import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D(ExtensionRange(ExtensionRange))
import qualified Text.DescriptorProtos.DescriptorProto.ExtensionRange as D.ExtensionRange(ExtensionRange(..))
import qualified Text.DescriptorProtos.EnumDescriptorProto as D(EnumDescriptorProto(EnumDescriptorProto))
import qualified Text.DescriptorProtos.EnumDescriptorProto as D.EnumDescriptorProto(EnumDescriptorProto(..))
import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D(EnumValueDescriptorProto)
import qualified Text.DescriptorProtos.EnumValueDescriptorProto as D.EnumValueDescriptorProto(EnumValueDescriptorProto(..))
import qualified Text.DescriptorProtos.FieldDescriptorProto as D(FieldDescriptorProto(FieldDescriptorProto))
import qualified Text.DescriptorProtos.FieldDescriptorProto as D.FieldDescriptorProto(FieldDescriptorProto(..))
import Text.DescriptorProtos.FieldDescriptorProto.Label
import qualified Text.DescriptorProtos.FieldDescriptorProto.Type as D(Type)
import Text.DescriptorProtos.FieldDescriptorProto.Type as D.Type(Type(..))
import qualified Text.DescriptorProtos.FileDescriptorProto as D(FileDescriptorProto)
import qualified Text.DescriptorProtos.FileDescriptorProto as D.FileDescriptorProto(FileDescriptorProto(..))
import qualified Text.DescriptorProtos.MethodDescriptorProto as D(MethodDescriptorProto)
import qualified Text.DescriptorProtos.MethodDescriptorProto as D.MethodDescriptorProto(MethodDescriptorProto(..))
import qualified Text.DescriptorProtos.OneofDescriptorProto as D(OneofDescriptorProto)
import qualified Text.DescriptorProtos.OneofDescriptorProto as D.OneofDescriptorProto(OneofDescriptorProto(..))
import qualified Text.DescriptorProtos.ServiceDescriptorProto as D(ServiceDescriptorProto)
import qualified Text.DescriptorProtos.ServiceDescriptorProto as D.ServiceDescriptorProto(ServiceDescriptorProto(..))
import qualified Text.DescriptorProtos.UninterpretedOption as D(UninterpretedOption)
import qualified Text.DescriptorProtos.UninterpretedOption as D.UninterpretedOption(UninterpretedOption(..))
import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D(NamePart(NamePart))
import qualified Text.DescriptorProtos.UninterpretedOption.NamePart as D.NamePart(NamePart(..))
import qualified Text.DescriptorProtos.EnumOptions as D.EnumOptions(EnumOptions(uninterpreted_option))
import qualified Text.DescriptorProtos.EnumValueOptions as D.EnumValueOptions(EnumValueOptions(uninterpreted_option))
import qualified Text.DescriptorProtos.FieldOptions as D(FieldOptions(FieldOptions))
import qualified Text.DescriptorProtos.FieldOptions as D.FieldOptions(FieldOptions(packed,uninterpreted_option))
import qualified Text.DescriptorProtos.FileOptions as D.FileOptions(FileOptions(..))
import qualified Text.DescriptorProtos.MessageOptions as D.MessageOptions(MessageOptions(uninterpreted_option))
import qualified Text.DescriptorProtos.MethodOptions as D.MethodOptions(MethodOptions(uninterpreted_option))
import qualified Text.DescriptorProtos.ServiceOptions as D.ServiceOptions(ServiceOptions(uninterpreted_option))
import qualified Text.Google.Protobuf.Compiler.CodeGeneratorRequest as CGR
import Text.ProtocolBuffers.Header
import Text.ProtocolBuffers.Identifiers
import Text.ProtocolBuffers.Extensions
import Text.ProtocolBuffers.WireMessage
import Text.ProtocolBuffers.ProtoCompile.Instances
import Text.ProtocolBuffers.ProtoCompile.Parser
import Control.Applicative
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Error
import Control.Monad.Writer
import Data.Char
import Data.Ratio
import Data.Ix(inRange)
import Data.List(foldl',stripPrefix,isPrefixOf,isSuffixOf)
import Data.Map(Map)
import Data.Maybe(mapMaybe,isNothing)
import Data.Typeable
import System.Directory(doesFileExist,canonicalizePath)
import qualified System.FilePath as Local(pathSeparator,splitDirectories,joinPath,combine,makeRelative)
import qualified System.FilePath.Posix as Canon(pathSeparator,splitDirectories,joinPath,takeBaseName)
import qualified Data.ByteString.Lazy.Char8 as LC
import qualified Data.ByteString.Lazy.UTF8 as U
import qualified Data.Foldable as F
import qualified Data.Sequence as Seq
import qualified Data.Map as M
import qualified Data.Set as Set
import qualified Data.Traversable as T
indent :: String -> String
indent = unlines . map (\str -> ' ':' ':str) . lines
ishow :: Show a => a -> String
ishow = indent . show
errMsg :: String -> String
errMsg s = "Text.ProtocolBuffers.ProtoCompile.Resolve fatal error encountered, message:\n"++indent s
err :: forall b. String -> b
err = error . errMsg
throw :: (Error e, MonadError e m) => String -> m a
throw s = throwError (strMsg (errMsg s))
annErr :: (MonadError String m) => String -> m a -> m a
annErr s act = catchError act (\e -> throwError ("Text.ProtocolBuffers.ProtoCompile.Resolve annErr: "++s++'\n':indent e))
getJust :: (Error e,MonadError e m, Typeable a) => String -> Maybe a -> m a
{-# INLINE getJust #-}
getJust s ma@Nothing = throw $ "Impossible? Expected Just of type "++show (typeOf ma)++" but got nothing:\n"++indent s
getJust _s (Just a) = return a
defaultPackageName :: Utf8
defaultPackageName = Utf8 (LC.pack "defaultPackageName")
data PackageID a = PackageID { _getPackageID :: a }
| NoPackageID { _getNoPackageID :: a }
deriving (Show)
instance Functor PackageID where
fmap f (PackageID a) = PackageID (f a)
fmap f (NoPackageID a) = NoPackageID (f a)
getPackageID :: PackageID a -> a
getPackageID (PackageID a) = a
getPackageID (NoPackageID a) = a
getPackage :: D.FileDescriptorProto -> PackageID Utf8
getPackage fdp = case D.FileDescriptorProto.package fdp of
Just a -> PackageID a
Nothing -> case D.FileDescriptorProto.name fdp of
Nothing -> NoPackageID defaultPackageName
Just filename -> case convertFileToPackage filename of
Nothing -> NoPackageID defaultPackageName
Just name -> NoPackageID name
checkPackageID :: PackageID Utf8 -> Either String (PackageID (Bool,[IName Utf8]))
checkPackageID (PackageID a) = fmap PackageID (checkDIUtf8 a)
checkPackageID (NoPackageID a) = fmap NoPackageID (checkDIUtf8 a)
convertFileToPackage :: Utf8 -> Maybe Utf8
convertFileToPackage filename =
let full = toString filename
suffix = ".proto"
noproto = if suffix `isSuffixOf` full then take (length full - length suffix) full else full
convert :: Bool -> String -> String
convert _ [] = []
convert toUp (x:xs) | inRange ('a','z') x = if toUp
then toUpper x : convert False xs
else x : convert False xs
| inRange ('A','Z') x = x : convert False xs
| inRange ('0','9') x = x : convert True xs
| '_' == x = x : convert True xs
| otherwise = convert True xs
converted = convert True noproto
leading = case converted of
(x:_) | inRange ('0','9') x -> "proto_" ++ converted
_ -> converted
in if null leading then Nothing else (Just (fromString leading))
joinDot :: [IName String] -> FIName String
joinDot [] = err $ "joinDot on an empty list of IName!"
joinDot (x:xs) = fqAppend (promoteFI x) xs
checkFI :: [(FieldId,FieldId)] -> FieldId -> Bool
checkFI ers fid = any (`inRange` fid) ers
getExtRanges :: D.DescriptorProto -> [(FieldId,FieldId)]
getExtRanges d = concatMap check unchecked
where check x@(lo,hi) | hi < lo = []
| hi<19000 || 19999<lo = [x]
| otherwise = concatMap check [(lo,18999),(20000,hi)]
unchecked = F.foldr ((:) . extToPair) [] (D.DescriptorProto.extension_range d)
extToPair (D.ExtensionRange
{ D.ExtensionRange.start = start
, D.ExtensionRange.end = end }) =
(maybe minBound FieldId start, maybe maxBound (FieldId . pred) end)
data Env = Local [IName String] EMap Env
| Global TopLevel [TopLevel]
deriving Show
data TopLevel = TopLevel { top'Path :: FilePath
, top'Package :: PackageID [IName String]
, top'FDP :: Either ErrStr D.FileDescriptorProto
, top'mVals :: EMap } deriving Show
type EMap = Map (IName String) E'Entity
data Entity = E'Message { eName :: [IName String], validExtensions :: [(FieldId,FieldId)]
, mVals :: EMap }
| E'Group { eName :: [IName String], mVals :: EMap }
| E'Service { eName :: [IName String], mVals :: EMap }
| E'Key { eName :: [IName String], eMsg :: Either ErrStr Entity
, fNumber :: FieldId, fType :: Maybe D.Type
, mVal :: Maybe (Either ErrStr Entity) }
| E'Field { eName :: [IName String], fNumber :: FieldId, fType :: Maybe D.Type
, mVal :: Maybe (Either ErrStr Entity) }
| E'Enum { eName :: [IName String], eVals :: Map (IName Utf8) Int32 }
| E'Method { eName :: [IName String], eMsgIn,eMsgOut :: Maybe (Either ErrStr Entity) }
deriving (Show)
data E'Entity = E'Ok Entity
| E'Error String [E'Entity]
deriving (Show)
newtype LocalFP = LocalFP { unLocalFP :: FilePath } deriving (Read,Show,Eq,Ord)
newtype CanonFP = CanonFP { unCanonFP :: FilePath } deriving (Read,Show,Eq,Ord)
fpLocalToCanon :: LocalFP -> CanonFP
fpLocalToCanon | Canon.pathSeparator == Local.pathSeparator = CanonFP . unLocalFP
| otherwise = CanonFP . Canon.joinPath . Local.splitDirectories . unLocalFP
fpCanonToLocal :: CanonFP -> LocalFP
fpCanonToLocal | Canon.pathSeparator == Local.pathSeparator = LocalFP . unCanonFP
| otherwise = LocalFP . Local.joinPath . Canon.splitDirectories . unCanonFP
allowedGlobal :: Env -> [(PackageID [IName String],[IName String])]
allowedGlobal (Local _ _ env) = allowedGlobal env
allowedGlobal (Global t ts) = map allowedT (t:ts)
allowedT :: TopLevel -> (PackageID [IName String], [IName String])
allowedT tl = (top'Package tl,M.keys (top'mVals tl))
allowedLocal :: Env -> [([IName String],[IName String])]
allowedLocal (Global _t _ts) = []
allowedLocal (Local name vals env) = allowedE : allowedLocal env
where allowedE :: ([IName String], [IName String])
allowedE = (name,M.keys vals)
type ReMap = Map (FIName Utf8) ProtoName
data NameMap = NameMap ( PackageID (FIName Utf8)
, [MName String]
, [MName String])
ReMap
deriving (Show)
type RE a = ReaderT Env (Either ErrStr) a
data SEnv = SEnv { my'Parent :: [IName String]
, my'Env :: Env }
emptyEntity :: Entity
emptyEntity = E'Service [IName "emptyEntity from myFix"] mempty
emptyEnv :: Env
emptyEnv = Global (TopLevel "emptyEnv from myFix" (PackageID [IName "emptyEnv form myFix"]) (Left "emptyEnv: top'FDP does not exist") mempty) []
instance Show SEnv where
show (SEnv p e) = "(SEnv "++show p++" ; "++ whereEnv e ++ ")"
type ErrStr = String
type SE a = ReaderT SEnv (Either ErrStr) a
runSE :: SEnv -> SE a -> Either ErrStr a
runSE sEnv m = runReaderT m sEnv
fqName :: Entity -> FIName Utf8
fqName = fiFromString . joinDot . eName
fiFromString :: FIName String -> FIName Utf8
fiFromString = FIName . fromString . fiName
iToString :: IName Utf8 -> IName String
iToString = IName . toString . iName
get'mVals'E :: E'Entity -> Maybe EMap
get'mVals'E (E'Ok entity) = get'mVals entity
get'mVals'E (E'Error {}) = Nothing
get'mVals :: Entity -> Maybe EMap
get'mVals (E'Message {mVals = x}) = Just x
get'mVals (E'Group {mVals = x}) = Just x
get'mVals (E'Service {mVals = x}) = Just x
get'mVals _ = Nothing
toGlobal :: Env -> Env
toGlobal (Local _ _ env) = toGlobal env
toGlobal x@(Global {}) = x
getTL :: Env -> TopLevel
getTL (Local _ _ env) = getTL env
getTL (Global tl _tls) = tl
getTLS :: Env -> (TopLevel,[TopLevel])
getTLS (Local _ _ env) = getTLS env
getTLS (Global tl tls) = (tl, tls)
resolveHere :: Entity -> Utf8 -> RE Entity
resolveHere parent nameU = do
let rFail msg = throw ("Could not lookup "++show (toString nameU)++"\n"++indent msg)
x <- getJust ("resolveHere: validI nameU failed for "++show nameU) (fmap iToString (validI nameU))
case get'mVals parent of
Just vals -> case M.lookup x vals of
Just (E'Ok entity) -> return entity
Just (E'Error s _) -> rFail ("because the name resolved to an error:\n" ++ indent s)
Nothing -> rFail ("because there is no such name here: "++show (eName parent))
Nothing -> rFail ("because environment has no local names:\n"++ishow (eName parent))
resolvePredEnv :: String -> (E'Entity -> Bool) -> Utf8 -> Env -> Either ErrStr Entity
resolvePredEnv userMessage accept nameU envIn = do
(isGlobal,xs) <- checkDIUtf8 nameU
let mResult = if isGlobal then lookupEnv (map iToString xs) (toGlobal envIn)
else lookupEnv (map iToString xs) envIn
case mResult of
Just (E'Ok e) -> return e
Just (E'Error s _es) -> throw s
Nothing -> throw . unlines $ [ "resolvePredEnv: Could not lookup " ++ show nameU
, "which parses as " ++ show (isGlobal,xs)
, "in environment: " ++ (whereEnv envIn)
, "looking for: " ++ userMessage
, "allowed (local): " ++ show (allowedLocal envIn)
, "allowed (global): " ++ show (allowedGlobal envIn) ]
where
lookupEnv :: [IName String] -> Env -> Maybe E'Entity
lookupEnv xs (Global tl tls) = let findThis = lookupTopLevel main xs
where main = top'Package tl
in msum (map findThis (tl:tls))
lookupEnv xs (Local _ vals env) = filteredLookup vals xs <|> lookupEnv xs env
lookupTopLevel :: PackageID [IName String] -> [IName String] -> TopLevel -> Maybe E'Entity
lookupTopLevel main xs tl =
(if matchesMain main (top'Package tl) then filteredLookup (top'mVals tl) xs else Nothing)
<|>
(matchPrefix (top'Package tl) xs >>= filteredLookup (top'mVals tl))
<|>
(testPrefix main (top'Package tl) >> filteredLookup (top'mVals tl) xs)
where matchesMain (PackageID {_getPackageID=a}) (PackageID {_getPackageID=b}) = a==b
matchesMain (NoPackageID {}) (PackageID {}) = False
matchesMain (PackageID {}) (NoPackageID {}) = True
matchesMain (NoPackageID {}) (NoPackageID {}) = True
matchPrefix (NoPackageID {}) _ = Nothing
matchPrefix (PackageID {_getPackageID=a}) ys = stripPrefix a ys
testPrefix (PackageID {_getPackageID=child}) (PackageID {_getPackageID=parent}) = stripPrefix parent child
testPrefix _ _ = Nothing
filteredLookup valsIn namesIn =
let lookupVals :: EMap -> [IName String] -> Maybe E'Entity
lookupVals _vals [] = Nothing
lookupVals vals [x] = M.lookup x vals
lookupVals vals (x:xs) = do
entity <- M.lookup x vals
case get'mVals'E entity of
Just vals' -> lookupVals vals' xs
Nothing -> Nothing
m'x = lookupVals valsIn namesIn
in case m'x of
Just entity | accept entity -> m'x
_ -> Nothing
resolveEnv :: Utf8 -> Env -> Either ErrStr Entity
resolveEnv = resolvePredEnv "Any item" (const True)
resolveRE :: Utf8 -> RE Entity
resolveRE nameU = lift . (resolveEnv nameU) =<< ask
getType :: Show a => String -> (a -> Maybe Utf8) -> a -> SE (Maybe (Either ErrStr Entity))
getType s f a = do
typeU <- getJust s (f a)
case parseType (toString typeU) of
Just _ -> return Nothing
Nothing -> do ee <- resolveSE typeU
return (Just (expectMGE ee))
where
resolveSE :: Utf8 -> SE (Either ErrStr Entity)
resolveSE nameU = fmap (resolveEnv nameU) (asks my'Env)
expectMGE :: Either ErrStr Entity -> Either ErrStr Entity
expectMGE ee@(Left {}) = ee
expectMGE ee@(Right e) | isMGE = ee
| otherwise = throw $ "expectMGE: Name resolution failed to find a Message, Group, or Enum:\n"++ishow (eName e)
where isMGE = case e of E'Message {} -> True
E'Group {} -> True
E'Enum {} -> True
_ -> False
whereEnv :: Env -> String
whereEnv (Local name _ env) = fiName (joinDot name) ++ " in "++show (top'Path . getTL $ env)
whereEnv (Global tl _) = formatPackageID ++ " in " ++ show (top'Path tl)
where formatPackageID = case top'Package tl of
PackageID {_getPackageID=x} -> fiName (joinDot x)
NoPackageID {_getNoPackageID=y} -> show y
partEither :: [Either a b] -> ([a],[b])
partEither [] = ([],[])
partEither (Left a:xs) = let ~(ls,rs) = partEither xs
in (a:ls,rs)
partEither (Right b:xs) = let ~(ls,rs) = partEither xs
in (ls,b:rs)
unique :: IName String -> E'Entity -> E'Entity -> E'Entity
unique name (E'Error _ a) (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a++b)
unique name (E'Error _ a) b = E'Error ("Namespace collision for "++show name) (a++[b])
unique name a (E'Error _ b) = E'Error ("Namespace collision for "++show name) (a:b)
unique name a b = E'Error ("Namespace collision for "++show name) [a,b]
maybeM :: Monad m => (x -> m a) -> (Maybe x) -> m (Maybe a)
maybeM f mx = maybe (return Nothing) (liftM Just . f) mx
type MRM a = ReaderT ProtoName (WriterT [(FIName Utf8,ProtoName)] (Either ErrStr)) a
runMRM'Reader :: MRM a -> ProtoName -> WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a
runMRM'Reader = runReaderT
runMRM'Writer :: WriterT [(FIName Utf8,ProtoName)] (Either ErrStr) a -> Either ErrStr (a,[(FIName Utf8,ProtoName)])
runMRM'Writer = runWriterT
mrmName :: String -> (a -> Maybe Utf8) -> a -> MRM ProtoName
mrmName s f a = do
template <- ask
iSelf <- getJust s (validI =<< f a)
let mSelf = mangle iSelf
fqSelf = fqAppend (protobufName template) [iSelf]
self = template { protobufName = fqSelf
, baseName = mSelf }
template' = template { protobufName = fqSelf
, parentModule = parentModule template ++ [mSelf] }
tell [(fqSelf,self)]
return template'
makeNameMaps :: [MName String] -> [(CanonFP,[MName String])] -> Env -> Either ErrStr NameMap
makeNameMaps hPrefix hAs env = do
let getPrefix fdp =
case D.FileDescriptorProto.name fdp of
Nothing -> hPrefix
Just n -> let path = CanonFP (toString n)
in case lookup path hAs of
Just p -> p
Nothing -> case lookup (CanonFP . Canon.takeBaseName . unCanonFP $ path) hAs of
Just p -> p
Nothing -> hPrefix
let (tl,tls) = getTLS env
(fdp:fdps) <- mapM top'FDP (tl:tls)
(NameMap tuple m) <- makeNameMap (getPrefix fdp) fdp
let f (NameMap _ x) = x
ms <- fmap (map f) . mapM (\y -> makeNameMap (getPrefix y) y) $ fdps
let nameMap = (NameMap tuple (M.unions (m:ms)))
return nameMap
makeNameMap :: [MName String] -> D.FileDescriptorProto -> Either ErrStr NameMap
makeNameMap hPrefix fdpIn = go (makeOne fdpIn) where
go = fmap ((\(a,w) -> NameMap a (M.fromList w))) . runMRM'Writer
makeOne fdp = do
let rawPackage = getPackage fdp :: PackageID Utf8
_ <- lift (checkPackageID rawPackage)
let packageName :: PackageID (FIName Utf8)
packageName = fmap (difi . DIName) rawPackage
fi'package'name = getPackageID packageName
rawParent <- getJust "makeNameMap.makeOne: impossible Nothing found" . msum $
[ D.FileOptions.java_outer_classname =<< (D.FileDescriptorProto.options fdp)
, D.FileOptions.java_package =<< (D.FileDescriptorProto.options fdp)
, Just (getPackageID rawPackage)]
diParent <- getJust ("makeNameMap.makeOne: invalid character in: "++show rawParent)
(validDI rawParent)
let hParent = map (mangle :: IName Utf8 -> MName String) . splitDI $ diParent
template = ProtoName fi'package'name hPrefix hParent
(error "makeNameMap.makeOne.template.baseName undefined")
runMRM'Reader (mrmFile fdp) template
return (packageName,hPrefix,hParent)
fieldNotOneof :: D.DescriptorProto -> Seq D.FieldDescriptorProto
fieldNotOneof = Seq.filter (isNothing . D.FieldDescriptorProto.oneof_index) . D.DescriptorProto.field
oneofFieldMap :: D.DescriptorProto -> [(D.OneofDescriptorProto,Seq D.FieldDescriptorProto)]
oneofFieldMap dp = zip odps fdpss
where odps = F.toList (D.DescriptorProto.oneof_decl dp)
fdps = D.DescriptorProto.field dp
fdpss = map (\i->Seq.filter ((== Just i) . D.FieldDescriptorProto.oneof_index) fdps) [0..]
mrmFile :: D.FileDescriptorProto -> MRM ()
mrmFile fdp = do
F.mapM_ mrmMsg (D.FileDescriptorProto.message_type fdp)
F.mapM_ mrmField (D.FileDescriptorProto.extension fdp)
F.mapM_ mrmEnum (D.FileDescriptorProto.enum_type fdp)
F.mapM_ mrmService (D.FileDescriptorProto.service fdp)
mrmMsg dp = do
template <- mrmName "mrmMsg.name" D.DescriptorProto.name dp
local (const template) $ do
F.mapM_ mrmEnum (D.DescriptorProto.enum_type dp)
F.mapM_ mrmField (D.DescriptorProto.extension dp)
F.mapM_ mrmField (fieldNotOneof dp)
F.mapM_ mrmOneof (oneofFieldMap dp)
F.mapM_ mrmMsg (D.DescriptorProto.nested_type dp)
mrmField fdp = mrmName "mrmField.name" D.FieldDescriptorProto.name fdp
mrmOneof (odp,fdps) = do
template <- mrmName "mrmOneof.name" D.OneofDescriptorProto.name odp
local (const template) $
F.mapM_ mrmField fdps
mrmEnum edp = do
template <- mrmName "mrmEnum.name" D.EnumDescriptorProto.name edp
local (const template) $ F.mapM_ mrmEnumValue (D.EnumDescriptorProto.value edp)
mrmEnumValue evdp = mrmName "mrmEnumValue.name" D.EnumValueDescriptorProto.name evdp
mrmService sdp = do
template <- mrmName "mrmService.name" D.ServiceDescriptorProto.name sdp
local (const template) $ F.mapM_ mrmMethod (D.ServiceDescriptorProto.method sdp)
mrmMethod mdp = mrmName "mrmMethod.name" D.MethodDescriptorProto.name mdp
getNames :: String -> (a -> Maybe Utf8) -> a -> SE (IName String,[IName String])
getNames errorMessage accessor record = do
parent <- asks my'Parent
iSelf <- fmap iToString $ getJust errorMessage (validI =<< accessor record)
let names = parent ++ [ iSelf ]
return (iSelf,names)
descend :: [IName String] -> Entity -> SE a -> SE a
descend names entity act = local mutate act
where mutate (SEnv _parent env) = SEnv parent' env'
where parent' = names
env' = Local (eName entity) (mVals entity) env
kids :: (x -> SE (IName String,E'Entity)) -> Seq x -> SE ([ErrStr],[(IName String,E'Entity)])
kids f xs = do sEnv <- ask
let ans = map (runSE sEnv) . map f . F.toList $ xs
return (partEither ans)
makeTopLevel :: D.FileDescriptorProto -> PackageID [IName String] -> [TopLevel] -> Either ErrStr Env
makeTopLevel fdp packageName imports = do
filePath <- getJust "makeTopLevel.filePath" (D.FileDescriptorProto.name fdp)
let
isGroup = (`elem` groupNames) where
groupNamesRaw = map toString . mapMaybe D.FieldDescriptorProto.type_name
. filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type')
$ (F.toList . D.FileDescriptorProto.extension $ fdp)
groupNamesI = mapMaybe validI groupNamesRaw
groupNamesDI = mapMaybe validDI groupNamesRaw
groupNames = groupNamesI ++ map (last . splitDI) groupNamesDI
(bad,global) <- myFixE ("makeTopLevel myFixE",emptyEnv) $ \ global'Param ->
let sEnv = SEnv (get'SEnv'root'from'PackageID packageName) global'Param
in runSE sEnv $ do
(bads,children) <- fmap unzip . sequence $
[ kids (entityMsg isGroup) (D.FileDescriptorProto.message_type fdp)
, kids (entityField True) (D.FileDescriptorProto.extension fdp)
, kids entityEnum (D.FileDescriptorProto.enum_type fdp)
, kids entityService (D.FileDescriptorProto.service fdp) ]
let bad' = unlines (concat bads)
global' = Global (TopLevel (toString filePath)
packageName
(resolveFDP fdp global')
(M.fromListWithKey unique (concat children)))
imports
return (bad',global')
when (not (null bad)) $
throw $ "makeTopLevel.bad: Some children failed for "++show filePath++"\n"++bad
return global
where resolveFDP :: D.FileDescriptorProto -> Env -> Either ErrStr D.FileDescriptorProto
resolveFDP fdpIn env = runRE env (fqFileDP fdpIn)
where runRE :: Env -> RE D.FileDescriptorProto -> Either ErrStr D.FileDescriptorProto
runRE envIn m = runReaderT m envIn
get'SEnv'root'from'PackageID :: PackageID [IName String] -> [IName String]
get'SEnv'root'from'PackageID = getPackageID
myFixSE :: (String,a) -> (a -> SE (String,a)) -> SE (String,a)
myFixSE s f = ReaderT $ \r -> myFixE s (\a -> runReaderT (f a) r)
myFixE :: (String,a) -> (a -> Either ErrStr (String,a)) -> Either ErrStr (String,a)
myFixE s f = let a = f (unRight a) in a
where unRight (Right x) = snd x
unRight (Left _msg) = snd s
entityMsg :: (IName String -> Bool) -> D.DescriptorProto -> SE (IName String,E'Entity)
entityMsg isGroup dp = annErr ("entityMsg DescriptorProto name is "++show (D.DescriptorProto.name dp)) $ do
(self,names) <- getNames "entityMsg.name" D.DescriptorProto.name dp
numbers <- fmap Set.fromList . mapM (getJust "entityMsg.field.number" . D.FieldDescriptorProto.number) . F.toList . D.DescriptorProto.field $ dp
when (Set.size numbers /= Seq.length (D.DescriptorProto.field dp)) $
throwError $ "entityMsg.field.number: There must be duplicate field numbers for "++show names++"\n "++show numbers
let groupNamesRaw = map toString . mapMaybe D.FieldDescriptorProto.type_name
. filter (maybe False (TYPE_GROUP ==) . D.FieldDescriptorProto.type')
$ (F.toList . D.DescriptorProto.field $ dp) ++ (F.toList . D.DescriptorProto.extension $ dp)
groupNamesI = mapMaybe validI groupNamesRaw
groupNamesDI = mapMaybe validDI groupNamesRaw
groupNames = groupNamesI ++ map (last . splitDI) groupNamesDI
isGroup' = (`elem` groupNames)
(bad,entity) <- myFixSE ("myFixSE entityMsg",emptyEntity) $ \ entity'Param -> descend names entity'Param $ do
(bads,children) <- fmap unzip . sequence $
[ kids entityEnum (D.DescriptorProto.enum_type dp)
, kids (entityField True) (D.DescriptorProto.extension dp)
, kids (entityField False) (D.DescriptorProto.field dp)
, kids (entityMsg isGroup') (D.DescriptorProto.nested_type dp) ]
let bad' = unlines (concat bads)
entity' | isGroup self = E'Group names (M.fromListWithKey unique (concat children))
| otherwise = E'Message names (getExtRanges dp) (M.fromListWithKey unique (concat children))
return (bad',entity')
when (not (null bad)) $
throwError $ "entityMsg.bad: Some children failed for "++show names++"\n"++bad
return (self,E'Ok $ entity)
entityField :: Bool -> D.FieldDescriptorProto -> SE (IName String,E'Entity)
entityField isKey fdp = annErr ("entityField FieldDescriptorProto name is "++show (D.FieldDescriptorProto.name fdp)) $ do
(self,names) <- getNames "entityField.name" D.FieldDescriptorProto.name fdp
let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)
when (isKey/=isKey') $
throwError $ "entityField: Impossible? Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),names,fdp)
number <- getJust "entityField.name" . D.FieldDescriptorProto.number $ fdp
let mType = D.FieldDescriptorProto.type' fdp
typeName <- maybeM resolveMGE (D.FieldDescriptorProto.type_name fdp)
if isKey
then do
extendee <- resolveM =<< getJust "entityField.extendee" (D.FieldDescriptorProto.extendee fdp)
return (self,E'Ok $ E'Key names extendee (FieldId number) mType typeName)
else
return (self,E'Ok $ E'Field names (FieldId number) mType typeName)
where
resolveMGE :: Utf8 -> SE (Either ErrStr Entity)
resolveMGE nameU = fmap (resolvePredEnv "Message or Group or Enum" isMGE nameU) (asks my'Env)
where isMGE (E'Ok e') = case e' of E'Message {} -> True
E'Group {} -> True
E'Enum {} -> True
_ -> False
isMGE (E'Error {}) = False
resolveM :: Utf8 -> SE (Either ErrStr Entity)
resolveM nameU = fmap (resolvePredEnv "Message" isM nameU) (asks my'Env)
where isM (E'Ok e') = case e' of E'Message {} -> True
_ -> False
isM (E'Error {}) = False
entityEnum :: D.EnumDescriptorProto -> SE (IName String,E'Entity)
entityEnum edp@(D.EnumDescriptorProto {D.EnumDescriptorProto.value=vs}) = do
(self,names) <- getNames "entityEnum.name" D.EnumDescriptorProto.name edp
values <- mapM (getJust "entityEnum.value.number" . D.EnumValueDescriptorProto.number) . F.toList $ vs
justNames <- mapM (\v -> getJust ("entityEnum.value.name failed for "++show v) (D.EnumValueDescriptorProto.name v))
. F.toList $ vs
valNames <- mapM (\n -> getJust ("validI of entityEnum.value.name failed for "++show n) (validI n)) justNames
let mapping = M.fromList (zip valNames values)
when (M.size mapping /= Seq.length vs) $
throwError $ "entityEnum.value.name: There must be duplicate enum names for "++show names++"\n "++show valNames
descend'Enum names $ F.mapM_ entityEnumValue vs
return (self,E'Ok $ E'Enum names mapping)
where entityEnumValue :: D.EnumValueDescriptorProto -> SE ()
entityEnumValue evdp = do
_ <- getNames "entityEnumValue.name" D.EnumValueDescriptorProto.name evdp
return ()
descend'Enum :: [IName String] -> SE a -> SE a
descend'Enum names act = local mutate act
where mutate (SEnv _parent env) = SEnv names env
entityService :: D.ServiceDescriptorProto -> SE (IName String,E'Entity)
entityService sdp = annErr ("entityService ServiceDescriptorProto name is "++show (D.ServiceDescriptorProto.name sdp)) $ do
(self,names) <- getNames "entityService.name" D.ServiceDescriptorProto.name sdp
(bad,entity) <- myFixSE ("myFixSE entityService",emptyEntity) $ \ entity'Param ->
descend names entity'Param $ do
(badMethods',goodMethods) <- kids entityMethod (D.ServiceDescriptorProto.method sdp)
let bad' = unlines badMethods'
entity' = E'Service names (M.fromListWithKey unique goodMethods)
return (bad',entity')
when (not (null bad)) $
throwError $ "entityService.badMethods: Some methods failed for "++show names++"\n"++bad
return (self,E'Ok entity)
entityMethod :: D.MethodDescriptorProto -> SE (IName String,E'Entity)
entityMethod mdp = do
(self,names) <- getNames "entityMethod.name" D.MethodDescriptorProto.name mdp
inputType <- getType "entityMethod.input_type" D.MethodDescriptorProto.input_type mdp
outputType <- getType "entityMethod.output_type" D.MethodDescriptorProto.output_type mdp
return (self,E'Ok $ E'Method names inputType outputType)
fqFail :: Show a => String -> a -> Entity -> RE b
fqFail msg dp entity = do
env <- ask
throw $ unlines [ msg, "resolving: "++show dp, "in environment: "++whereEnv env, "found: "++show (eName entity) ]
fqFileDP :: D.FileDescriptorProto -> RE D.FileDescriptorProto
fqFileDP fdp = annErr ("fqFileDP FileDescriptorProto (name,package) is "++show (D.FileDescriptorProto.name fdp,D.FileDescriptorProto.package fdp)) $ do
newMessages <- T.mapM fqMessage (D.FileDescriptorProto.message_type fdp)
newEnums <- T.mapM fqEnum (D.FileDescriptorProto.enum_type fdp)
newServices <- T.mapM fqService (D.FileDescriptorProto.service fdp)
newKeys <- T.mapM (fqField True) (D.FileDescriptorProto.extension fdp)
consumeUNO $ fdp { D.FileDescriptorProto.message_type = newMessages
, D.FileDescriptorProto.enum_type = newEnums
, D.FileDescriptorProto.service = newServices
, D.FileDescriptorProto.extension = newKeys }
fqMessage :: D.DescriptorProto -> RE D.DescriptorProto
fqMessage dp = annErr ("fqMessage DescriptorProto name is "++show (D.DescriptorProto.name dp)) $ do
entity <- resolveRE =<< getJust "fqMessage.name" (D.DescriptorProto.name dp)
(name,vals) <- case entity of
E'Message {eName=name',mVals=vals'} -> return (name',vals')
E'Group {eName=name',mVals=vals'} -> return (name',vals')
_ -> fqFail "fqMessage.entity: did not resolve to an E'Message or E'Group:" dp entity
local (\env -> (Local name vals env)) $ do
newFields <- T.mapM (fqField False) (D.DescriptorProto.field dp)
newKeys <- T.mapM (fqField True) (D.DescriptorProto.extension dp)
newMessages <- T.mapM fqMessage (D.DescriptorProto.nested_type dp)
newEnums <- T.mapM fqEnum (D.DescriptorProto.enum_type dp)
consumeUNO $ dp { D.DescriptorProto.field = newFields
, D.DescriptorProto.extension = newKeys
, D.DescriptorProto.nested_type = newMessages
, D.DescriptorProto.enum_type = newEnums }
fqService :: D.ServiceDescriptorProto -> RE D.ServiceDescriptorProto
fqService sdp = annErr ("fqService ServiceDescriptorProto name is "++show (D.ServiceDescriptorProto.name sdp)) $ do
entity <- resolveRE =<< getJust "fqService.name" (D.ServiceDescriptorProto.name sdp)
case entity of
E'Service {eName=name,mVals=vals} -> do
newMethods <- local (Local name vals) $ T.mapM fqMethod (D.ServiceDescriptorProto.method sdp)
consumeUNO $ sdp { D.ServiceDescriptorProto.method = newMethods }
_ -> fqFail "fqService.entity: did not resolve to a service:" sdp entity
fqMethod :: D.MethodDescriptorProto -> RE D.MethodDescriptorProto
fqMethod mdp = do
entity <- resolveRE =<< getJust "fqMethod.name" (D.MethodDescriptorProto.name mdp)
case entity of
E'Method {eMsgIn=msgIn,eMsgOut=msgOut} -> do
mdp1 <- case msgIn of
Nothing -> return mdp
Just resolveIn -> do
new <- fmap fqName (lift resolveIn)
return (mdp {D.MethodDescriptorProto.input_type = Just (fiName new)})
mdp2 <- case msgOut of
Nothing -> return mdp1
Just resolveIn -> do
new <- fmap fqName (lift resolveIn)
return (mdp1 {D.MethodDescriptorProto.output_type = Just (fiName new)})
consumeUNO mdp2
_ -> fqFail "fqMethod.entity: did not resolve to a Method:" mdp entity
fqField :: Bool -> D.FieldDescriptorProto -> RE D.FieldDescriptorProto
fqField isKey fdp = annErr ("fqField FieldDescriptorProto name is "++show (D.FieldDescriptorProto.name fdp)) $ do
let isKey' = maybe False (const True) (D.FieldDescriptorProto.extendee fdp)
when (isKey/=isKey') $
ask >>= \env -> throwError $ "fqField.isKey: Expected key and got field or vice-versa:\n"++ishow ((isKey,isKey'),whereEnv env,fdp)
entity <- expectFK =<< resolveRE =<< getJust "fqField.name" (D.FieldDescriptorProto.name fdp)
newExtendee <- case (isKey,entity) of
(True,E'Key {eMsg=msg,fNumber=fNum}) -> do
ext <- lift msg
case ext of
E'Message {} -> when (not (checkFI (validExtensions ext) fNum)) $
throwError $ "fqField.newExtendee: Field Number of extention key invalid:\n"
++unlines ["Number is "++show (fNumber entity)
,"Valid ranges: "++show (validExtensions ext)
,"Extendee: "++show (eName ext)
,"Descriptor: "++show fdp]
_ -> fqFail "fqField.ext: Key's target is not an E'Message:" fdp ext
fmap (Just . fiName . fqName) . lift . eMsg $ entity
(False,E'Field {}) -> return Nothing
_ -> fqFail "fqField.entity: did not resolve to expected E'Key or E'Field:" fdp entity
mTypeName <- maybeM lift (mVal entity)
actualType <- case (fType entity,mTypeName) of
(Just TYPE_GROUP, Just (E'Group {})) | isNotPacked fdp -> return TYPE_GROUP
| otherwise ->
fqFail ("fqField.actualType : This Group is invalid, you cannot pack a group field.") fdp entity
(Nothing, Just (E'Message {})) | isNotPacked fdp -> return TYPE_MESSAGE
| otherwise ->
fqFail ("fqField.actualType : This Message is invalid, you cannot pack a message field.") fdp entity
(Nothing, Just (E'Enum {})) | isNotPacked fdp -> return TYPE_ENUM
| isRepeated fdp -> return TYPE_ENUM
| otherwise ->
fqFail ("fqField.actualType : This Enum is invalid, you cannot pack a non-repeated field.") fdp entity
(Just t, Nothing) -> return t
(Just TYPE_MESSAGE, Just (E'Message {})) -> return TYPE_MESSAGE
(Just TYPE_ENUM, Just (E'Enum {})) -> return TYPE_ENUM
(mt,me) -> fqFail ("fqField.actualType: "++show mt++" and "++show (fmap eName me)++" is invalid.") fdp entity
case (mTypeName,D.FieldDescriptorProto.default_value fdp) of
(Just ee@(E'Enum {eVals = enumVals}),Just enumVal) ->
let badVal = throwError $ "fqField.default_value: Default enum value is invalid:\n"
++unlines ["Value is "++show (toString enumVal)
,"Allowed values from "++show (eName ee)
," are "++show (M.keys enumVals)
,"Descriptor: "++show fdp]
in case validI enumVal of
Nothing -> badVal
Just iVal -> when (M.notMember iVal enumVals) badVal
_ -> return ()
consumeUNO $
if isKey then (fdp { D.FieldDescriptorProto.extendee = newExtendee
, D.FieldDescriptorProto.type' = Just actualType
, D.FieldDescriptorProto.type_name = fmap (fiName . fqName) mTypeName })
else (fdp { D.FieldDescriptorProto.type' = Just actualType
, D.FieldDescriptorProto.type_name = fmap (fiName . fqName) mTypeName })
where isRepeated :: D.FieldDescriptorProto -> Bool
isRepeated (D.FieldDescriptorProto {
D.FieldDescriptorProto.label =
Just LABEL_REPEATED }) =
True
isRepeated _ = False
isNotPacked :: D.FieldDescriptorProto -> Bool
isNotPacked (D.FieldDescriptorProto {
D.FieldDescriptorProto.options =
Just (D.FieldOptions {
D.FieldOptions.packed =
Just isPacked })}) =
not isPacked
isNotPacked _ = True
expectFK :: Entity -> RE Entity
expectFK e | isFK = return e
| otherwise = throwError $ "expectF: Name resolution failed to find a Field or Key:\n"++ishow (eName e)
where isFK = case e of E'Field {} -> True
E'Key {} -> True
_ -> False
fqEnum :: D.EnumDescriptorProto -> RE D.EnumDescriptorProto
fqEnum edp = do
entity <- resolveRE =<< getJust "fqEnum.name" (D.EnumDescriptorProto.name edp)
case entity of
E'Enum {} -> do evdps <- T.mapM consumeUNO (D.EnumDescriptorProto.value edp)
consumeUNO $ edp { D.EnumDescriptorProto.value = evdps }
_ -> fqFail "fqEnum.entity: did not resolve to an E'Enum:" edp entity
class ConsumeUNO a where consumeUNO :: a -> RE a
instance ConsumeUNO D.EnumDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.EnumDescriptorProto.options = Just o })
(D.EnumDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "EnumOptions" m (D.EnumOptions.uninterpreted_option m)
return (m' { D.EnumOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.EnumValueDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.EnumValueDescriptorProto.options = Just o })
(D.EnumValueDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "EnumValueOptions" m (D.EnumValueOptions.uninterpreted_option m)
return (m' { D.EnumValueOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.MethodDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.MethodDescriptorProto.options = Just o })
(D.MethodDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "MethodOptions" m (D.MethodOptions.uninterpreted_option m)
return (m' { D.MethodOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.ServiceDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.ServiceDescriptorProto.options = Just o })
(D.ServiceDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "ServiceOptions" m (D.ServiceOptions.uninterpreted_option m)
return (m' { D.ServiceOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.FieldDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.FieldDescriptorProto.options = Just o })
(D.FieldDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "FieldOptions" m (D.FieldOptions.uninterpreted_option m)
return (m' { D.FieldOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.FileDescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.FileDescriptorProto.options = Just o })
(D.FileDescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "FileOptions" m (D.FileOptions.uninterpreted_option m)
return (m' { D.FileOptions.uninterpreted_option = mempty })
instance ConsumeUNO D.DescriptorProto where
consumeUNO a = maybe (return a) (processOpt >=> \o -> return $ a { D.DescriptorProto.options = Just o })
(D.DescriptorProto.options a)
where processOpt m = do m' <- interpretOptions "MessageOptions" m (D.MessageOptions.uninterpreted_option m)
return (m' { D.MessageOptions.uninterpreted_option = mempty })
interpretOptions :: ExtendMessage msg => String -> msg -> Seq D.UninterpretedOption -> RE msg
interpretOptions name msg unos = do
name' <- getJust ("interpretOptions: invalid name "++show name) (validI name)
ios <- mapM (interpretOption [IName "google",IName "protobuf",name']) . F.toList $ unos
let (ExtField ef) = getExtField msg
ef' = foldl' (\m (k,v) -> seq v $ M.insertWithKey mergeWires k v m) ef ios
mergeWires _k (ExtFromWire newData) (ExtFromWire oldData) =
ExtFromWire (mappend oldData newData)
mergeWires k a b = err $ "interpretOptions.mergeWires : impossible case\n"++show (k,a,b)
msg' = seq ef' (putExtField (ExtField ef') msg)
return msg'
interpretOption :: [IName String] -> D.UninterpretedOption -> RE (FieldId,ExtFieldValue)
interpretOption optName uno = case F.toList (D.UninterpretedOption.name uno) of
[] -> iFail $ "Empty name_part"
(part:parts) -> go Nothing optName part parts
where
iFail :: String -> RE a
iFail msg = do env <- ask
throw $ unlines [ "interpretOption: Failed to handle UninterpretedOption for: "++show optName
, " environment: "++whereEnv env
, " value: "++show uno
, " message: "++msg ]
go :: Maybe Entity -> [IName String] -> D.NamePart -> [D.NamePart] -> RE (FieldId,ExtFieldValue)
go mParent names (D.NamePart { D.NamePart.name_part = name
, D.NamePart.is_extension = isKey }) (next:rest) = do
(fk,entity) <-
if not isKey
then case mParent of
Nothing -> iFail $ "Cannot resolve local (is_extension False) name, no parent; expected (key)."
Just parent -> do
entity'field <- resolveHere parent name
case entity'field of
(E'Field {}) ->
case mVal entity'field of
Nothing -> iFail $ "Intermediate entry E'Field is of basic type, not E'Message or E'Group: "++show (names,eName entity'field)
Just val -> lift val >>= \e -> return (entity'field,e)
_ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Field: "++show (eName entity'field)
else do entity'key <- resolveRE name
case entity'key of
(E'Key {eMsg=msg}) -> do
extendee <- lift msg
when (eName extendee /= names) $
iFail $ "Intermediate entry E'Key extends wrong type: "++show (names,eName extendee)
case mVal entity'key of
Nothing-> iFail $ "Intermediate entry E'Key is of basic type, not E'Message or E'Group: "++show (names,eName entity'key)
Just val -> lift val >>= \e -> return (entity'key,e)
_ -> iFail $ "Name "++show (toString name)++" was resolved but was not an E'Key: "++show (eName entity'key)
t <- case entity of
E'Message {} -> return TYPE_MESSAGE
E'Group {} -> return TYPE_GROUP
_ -> iFail $ "Intermediate entry is not an E'Message or E'Group: "++show (eName entity)
(fid',ExtFromWire raw') <- go (Just entity) (eName entity) next rest
let tag@(WireTag tag') = mkWireTag fid' wt'
(EP wt' bs') = Seq.index raw' 0
let fid = fNumber fk
wt = toWireType (FieldType (fromEnum t))
bs = runPut $
case t of TYPE_MESSAGE -> do putSize (size'WireTag tag + LC.length bs')
putVarUInt tag'
putLazyByteString bs'
TYPE_GROUP -> do putVarUInt tag'
putLazyByteString bs'
putVarUInt (succ (getWireTag (mkWireTag fid wt)))
_ -> fail $ "bug! raw with type "++show t++" should be impossible"
return (fid,ExtFromWire (Seq.singleton (EP wt bs)))
go mParent names (D.NamePart { D.NamePart.name_part = name
, D.NamePart.is_extension = isKey }) [] = do
fk <- if isKey then resolveRE name
else case mParent of
Just parent -> resolveHere parent name
Nothing -> iFail $ "Cannot resolve local (is_extension False) name, no parent; expected (key)."
case fk of
E'Field {} | not isKey -> return ()
E'Key {} | isKey -> do
ext <- lift (eMsg fk)
when (eName ext /= names) $ iFail $ "Last entry E'Key extends wrong type: "++show (names,eName ext)
_ -> iFail $ "Last entity was resolved but was not an E'Field or E'Key: "++show fk
t <- case (fType fk) of
Nothing -> return TYPE_ENUM
Just TYPE_GROUP -> iFail $ "Last entry was a TYPE_GROUP instead of concrete value type"
Just TYPE_MESSAGE -> iFail $ "Last entry was a TYPE_MESSAGE instead of concrete value type"
Just typeCode -> return typeCode
let done :: Wire v => v -> RE (FieldId,ExtFieldValue)
done v = let ft = FieldType (fromEnum t)
wt = toWireType ft
fid = fNumber fk
in return (fid,ExtFromWire (Seq.singleton (EP wt (runPut (wirePut ft v)))))
case t of
TYPE_ENUM ->
case (mVal fk,D.UninterpretedOption.identifier_value uno,D.UninterpretedOption.aggregate_value uno) of
(Just (Right (E'Enum {eVals=enumVals})),Just enumVal,_) ->
case validI enumVal of
Nothing -> iFail $ "invalid D.UninterpretedOption.identifier_value: "++show enumVal
Just enumIVal -> case M.lookup enumIVal enumVals of
Nothing -> iFail $ "enumVal lookup failed: "++show (enumIVal,M.keys enumVals)
Just val -> done (fromEnum val)
(Just (Right (E'Enum {})),Nothing,_) -> iFail $ "No identifer_value value to lookup in E'Enum"
(Just (Right (E'Message {})),_,Nothing) -> iFail "Expected aggregate syntax to set a message option"
(Just (Right (E'Message {})),_,Just aggVal) -> iFail $ "\n\n\
\=========================================================================================\n\
\Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\
\=========================================================================================\n" ++ show aggVal
(Just (Right (E'Group {})),_,Nothing) -> iFail "Expected aggregate syntax to set a group option (impossible?)"
(Just (Right (E'Group {})),_,Just aggVal) -> iFail $ "\n\n\
\=========================================================================================\n\
\Google's 2.4.0 aggregate syntax for message options is not yet supported, value would be:\n\
\=========================================================================================\n" ++ show aggVal
(me,_,_) -> iFail $ "Expected Just E'Enum or E'Message or E'Group, got:\n"++show me
TYPE_STRING -> do
bs <- getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno)
maybe (done (Utf8 bs)) (\i -> iFail $ "Invalid utf8 in string_value at index: "++show i)
(isValidUTF8 bs)
TYPE_BYTES -> done =<< getJust "UninterpretedOption.string_value" (D.UninterpretedOption.string_value uno)
TYPE_BOOL -> done =<< bVal
TYPE_DOUBLE -> done =<< dVal
TYPE_FLOAT -> done =<< asFloat =<< dVal
TYPE_INT64 -> done =<< (iVal :: RE Int64)
TYPE_SFIXED64 -> done =<< (iVal :: RE Int64)
TYPE_SINT64 -> done =<< (iVal :: RE Int64)
TYPE_UINT64 -> done =<< (iVal :: RE Word64)
TYPE_FIXED64 -> done =<< (iVal :: RE Word64)
TYPE_INT32 -> done =<< (iVal :: RE Int32)
TYPE_SFIXED32 -> done =<< (iVal :: RE Int32)
TYPE_SINT32 -> done =<< (iVal :: RE Int32)
TYPE_UINT32 -> done =<< (iVal :: RE Word32)
TYPE_FIXED32 -> done =<< (iVal :: RE Word32)
_ -> iFail $ "bug! go with type "++show t++" should be impossible"
bVal :: RE Bool
bVal = let true = Utf8 (U.fromString "true")
false = Utf8 (U.fromString "false")
in case D.UninterpretedOption.identifier_value uno of
Just s | s == true -> return True
| s == false -> return False
_ -> iFail "Expected 'true' or 'false' identifier_value"
dVal :: RE Double
dVal = case (D.UninterpretedOption.negative_int_value uno
,D.UninterpretedOption.positive_int_value uno
,D.UninterpretedOption.double_value uno) of
(_,_,Just d) -> return d
(_,Just p,_) -> return (fromIntegral p)
(Just n,_,_) -> return (fromIntegral n)
_ -> iFail "No numeric value"
asFloat :: Double -> RE Float
asFloat d = let fmax :: Ratio Integer
fmax = (2-(1%2)^(23::Int)) * (2^(127::Int))
d' = toRational d
in if (negate fmax <= d') && (d' <= fmax)
then return (fromRational d')
else iFail $ "Double out of range for Float: "++show d
rangeCheck :: forall a. (Bounded a,Integral a) => Integer -> RE a
rangeCheck i = let r = (toInteger (minBound ::a),toInteger (maxBound :: a))
in if inRange r i then return (fromInteger i) else iFail $ "Constant out of range: "++show (r,i)
asInt :: Double -> RE Integer
asInt x = let (a,b) = properFraction x
in if b==0 then return a
else iFail $ "Double value not an integer: "++show x
iVal :: (Bounded y, Integral y) => RE y
iVal = case (D.UninterpretedOption.negative_int_value uno
,D.UninterpretedOption.positive_int_value uno
,D.UninterpretedOption.double_value uno) of
(_,Just p,_) -> rangeCheck (toInteger p)
(Just n,_,_) -> rangeCheck (toInteger n)
(_,_,Just d) -> rangeCheck =<< asInt d
_ -> iFail "No numeric value"
findFile :: [LocalFP] -> LocalFP -> IO (Maybe (LocalFP,CanonFP))
findFile paths (LocalFP target) = test paths where
test [] = return Nothing
test (LocalFP path:rest) = do
let fullname = Local.combine path target
found <- doesFileExist fullname
if not found
then test rest
else do truepath <- canonicalizePath path
truefile <- canonicalizePath fullname
if truepath `isPrefixOf` truefile
then do let rel = fpLocalToCanon (LocalFP (Local.makeRelative truepath truefile))
return (Just (LocalFP truefile,rel))
else fail $ "file found but it is not below path, cannot make canonical name:\n path: "
++show truepath++"\n file: "++show truefile
type DescriptorReader m = (Monad m) => LocalFP -> m (D.FileDescriptorProto, LocalFP)
loadProto' :: (Functor r,Monad r) => DescriptorReader r -> LocalFP -> r (Env,[D.FileDescriptorProto])
loadProto' fdpReader protoFile = goState (load Set.empty protoFile) where
goState act = do (env,m) <- runStateT act mempty
let fromRight (Right x) = x
fromRight (Left s) = error $ "loadProto failed to resolve a FileDescriptorProto: "++s
return (env,map (fromRight . top'FDP . fst . getTLS) (M.elems m))
load parentsIn file = do
built <- get
when (Set.member file parentsIn)
(loadFailed file (unlines ["imports failed: recursive loop detected"
,unlines . map show . M.assocs $ built,show parentsIn]))
case M.lookup file built of
Just result -> return result
Nothing -> do
(parsed'fdp, canonicalFile) <- lift $ fdpReader file
let rawPackage = getPackage parsed'fdp
packageName <- either (loadFailed canonicalFile . show)
(return . fmap (map iToString . snd))
(checkPackageID rawPackage)
let parents = Set.insert file parentsIn
importList = map (fpCanonToLocal . CanonFP . toString) . F.toList . D.FileDescriptorProto.dependency $ parsed'fdp
imports <- mapM (fmap getTL . load parents) importList
let eEnv = makeTopLevel parsed'fdp packageName imports
global'env <- either (loadFailed file) return eEnv
_ <- either (loadFailed file) return (top'FDP . getTL $ global'env)
modify (M.insert file global'env)
return global'env
loadFailed :: (Monad m) => LocalFP -> String -> m a
loadFailed f msg = fail . unlines $ ["Parsing proto:",show (unLocalFP f),"has failed with message",msg]
loadProto :: [LocalFP] -> LocalFP -> IO (Env,[D.FileDescriptorProto])
loadProto protoDirs protoFile = loadProto' findAndParseSource protoFile where
findAndParseSource :: DescriptorReader IO
findAndParseSource file = do
mayToRead <- liftIO $ findFile protoDirs file
case mayToRead of
Nothing -> loadFailed file (unlines (["loading failed, could not find file: "++show (unLocalFP file)
,"Searched paths were:"] ++ map ((" "++).show.unLocalFP) protoDirs))
Just (toRead,relpath) -> do
protoContents <- liftIO $ do putStrLn ("Loading filepath: "++show (unLocalFP toRead))
LC.readFile (unLocalFP toRead)
parsed'fdp <- either (loadFailed toRead . show) return $
(parseProto (unCanonFP relpath) protoContents)
return (parsed'fdp, toRead)
loadCodeGenRequest :: CGR.CodeGeneratorRequest -> LocalFP -> (Env,[D.FileDescriptorProto])
loadCodeGenRequest req protoFile = runIdentity $ loadProto' lookUpParsedSource protoFile where
lookUpParsedSource :: DescriptorReader Identity
lookUpParsedSource file = case M.lookup file fdpsByName of
Just result -> return (result, file)
Nothing -> loadFailed file ("Request refers to file: "++show (unLocalFP file)
++" but it was not supplied in the request.")
fdpsByName = M.fromList . map keyByName . F.toList . CGR.proto_file $ req
keyByName fdp = (fdpName fdp, fdp)
fdpName = LocalFP . maybe "" (LC.unpack . utf8) . D.FileDescriptorProto.name