yaml-rpc 1.0.1 → 1.0.2
raw patch · 7 files changed
+54/−26 lines, 7 files
Files
- Network/YAML/API.hs +10/−2
- Network/YAML/Caller.hs +4/−4
- Network/YAML/TH/Client.hs +17/−8
- Network/YAML/TH/Dispatcher.hs +15/−11
- Network/YAML/TH/Server.hs +6/−0
- Test/Client.hs +1/−0
- yaml-rpc.cabal +1/−1
Network/YAML/API.hs view
@@ -5,6 +5,7 @@ ) where import Control.Monad+import Control.Monad.IO.Class import Data.Char import Data.Yaml import qualified Data.ByteString as B@@ -29,6 +30,7 @@ | TText | TInteger | TDouble+ | TMaybe Type -- ^ @Maybe Type@. YAML notation is @Maybe Type@. | TList Type -- ^ @[Type]@. YAML notation is @List Type@. | TUser (M.Map T.Text Type) -- ^ User-defined record type | THaskell T.Text -- ^ Any Haskell type@@ -61,8 +63,11 @@ parseJSON (String "Double") = return TDouble parseJSON (String text) = do let lst = filter (not . T.null) $ T.split isSpace text- if (length lst == 2) && (head lst == "List")- then TList `fmap` parseJSON (String $ lst !! 1)+ if (length lst == 2)+ then case head lst of+ "List" -> TList `fmap` parseJSON (String $ lst !! 1)+ "Maybe" -> TMaybe `fmap` parseJSON (String $ lst !! 1)+ _ -> return (THaskell text) else return (THaskell text) parseJSON x@(Object v) = do typeFields <- parseJSON x@@ -106,6 +111,9 @@ toJSON (TList t) = case toJSON t of String s -> String $ "List " `T.append` s x -> error $ "Unsupported inner type for List: " ++ show x+ toJSON (TMaybe t) = case toJSON t of+ String s -> String $ "Maybe " `T.append` s+ x -> error $ "Unsupported inner type for Maybe: " ++ show x toJSON (TUser fields) = Object $ H.fromList [(name, toJSON t) | (name, t) <- M.assocs fields] toJSON (THaskell name) = String name
Network/YAML/Caller.hs view
@@ -3,6 +3,7 @@ module Network.YAML.Caller where import Control.Monad+import Control.Monad.IO.Class import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString as BS@@ -16,15 +17,14 @@ connectUri :: c -> String -- | Call remote method-call :: (ToJSON args, Connection srv, FromJSON result)+call :: (ToJSON args, Connection srv, FromJSON result, MonadIO m) => srv -- ^ Server connection; in simplest case - URL of service -> T.Text -- ^ Method name -> args -- ^ Method arguments- -> IO result+ -> m result call server method args = do let json = toJSON args- putStrLn $ "Sending request: " ++ show json- rs <- W.post (connectUri server ++ "/" ++ T.unpack method) json+ rs <- liftIO $ W.post (connectUri server ++ "/" ++ T.unpack method) json let body = rs ^. W.responseBody case decode (BL.toStrict body) of Nothing -> fail $ "Cannot decode response: " ++ show body
Network/YAML/TH/Client.hs view
@@ -3,6 +3,7 @@ module Network.YAML.TH.Client (generateAPI, useAPI) where import Control.Monad+import Control.Monad.IO.Class import qualified Data.Map as M import Language.Haskell.TH import Language.Haskell.TH.Syntax@@ -51,16 +52,17 @@ convertType API.TDouble = return $ ConT $ mkName "Double" convertType (API.THaskell name) = return $ ConT $ mkName (T.unpack name) convertType (API.TList t) = AppT ListT `fmap` convertType t+convertType (API.TMaybe t) = AppT (ConT $ mkName "Maybe") `fmap` convertType t convertType (API.TUser _) = fail $ "User-defined types cannot be nested" -methodType :: API.Method -> Q Type-methodType (API.Method methodArgs methodRet) = go (methodArgs ++ [methodRet])+methodType :: Name -> API.Method -> Q Type+methodType m (API.Method methodArgs methodRet) = go m (methodArgs ++ [methodRet]) where- go [r] = do+ go m [r] = do r' <- convertType r- return $ AppT (ConT $ mkName "IO") r'- go (t: ts) = do- result <- go ts+ return $ AppT (VarT m) r'+ go m (t: ts) = do+ result <- go m ts t' <- convertType t return $ AppT (AppT ArrowT t') result @@ -74,9 +76,16 @@ args <- forM argNames $ \name -> [| toJSON $(varE name) |] let c = clause (varP srv: argPatterns) (normalB [| call $(varE srv) $(lift text) $(return $ ListE args) |]) [] cName = mkName $ T.unpack text- mt <- methodType method+ monadName <- newName "monad"+ connName <- newName "connection"+ let connType = VarT connName+ let monadType = VarT monadName+ mt <- methodType monadName method+ let monadIO = mkName "MonadIO"+ let funType = AppT (AppT ArrowT connType) mt+ let resType = ForallT [PlainTV connName, PlainTV monadName] [ClassP monadIO [VarT monadName], ClassP (mkName "Connection") [VarT connName]] funType sequence [- sigD cName [t| (Connection c) => c -> $(return mt) |],+ sigD cName (return resType), funD cName [c] ]
Network/YAML/TH/Dispatcher.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards, FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell, OverloadedStrings, PatternGuards, FlexibleInstances, MultiParamTypeClasses #-} module Network.YAML.TH.Dispatcher- (ValueFn, ToValueFn (..), Dispatcher, generateDispatcher+ (ValueFn, ToValueFn (..), Dispatcher, generateDispatcherT, generateDispatcher ) where import Control.Monad+import Control.Monad.IO.Class import Data.Aeson hiding (json) import qualified Data.Text as T import qualified Data.Map as M@@ -15,16 +16,16 @@ import Network.YAML.API -type ValueFn = Value -> IO Value+type ValueFn m = Value -> m Value -- | Dispatcher function gets method name and returns corresponding function, or Nothing if there is no such method.-type Dispatcher = T.Text -> Maybe ValueFn+type Dispatcher m = T.Text -> Maybe (ValueFn m) -- | Only functions of this class can be exposed-class ToValueFn m where- toValueFn :: m -> ValueFn+class ToValueFn m f where+ toValueFn :: f -> ValueFn m -instance (ToJSON y) => ToValueFn (IO y) where+instance (ToJSON y, MonadIO m) => ToValueFn m (m y) where toValueFn fn = \rq -> do case rq of Array v -> case V.toList v of@@ -34,7 +35,7 @@ _ -> fail $ "Invalid number of arguments" _ -> fail $ "Invalid request format: " ++ show rq -instance (FromJSON x, ToValueFn f) => ToValueFn (x -> f) where+instance (Monad m, FromJSON x, ToValueFn m f) => ToValueFn m (x -> f) where toValueFn fn = \rq -> do case rq of Array v -> case V.toList v of@@ -47,13 +48,13 @@ _ -> fail $ "Invalid request format: " ++ show rq -- | Generate dispatcher function. This will generate function called @dispatcher@.-generateDispatcher :: API -> Q [Dec]-generateDispatcher (API _ _ methods) = do+generateDispatcherT :: Name -> API -> Q [Dec]+generateDispatcherT m (API _ _ methods) = do method <- newName "method" let c = clause [varP method] (normalB $ go method $ M.assocs methods) [] cName <- newName "dispatcher" sequence [- sigD cName [t| Dispatcher |],+ sigD cName [t| Dispatcher $(return $ ConT m) |], funD cName [c] ] where go _ [] = [| Nothing |]@@ -64,4 +65,7 @@ [| if $(varE method) == $(return $ LitE $ StringL nameStr) then Just $ toValueFn $(varE name) else $(other) |]++generateDispatcher :: API -> Q [Dec]+generateDispatcher api = generateDispatcherT (mkName "IO") api
Network/YAML/TH/Server.hs view
@@ -44,6 +44,9 @@ | "Double" <- nameBase name = [| API.TDouble |] | otherwise = [| API.THaskell $ T.pack $ $(stringLit $ nameBase name) |] convertType (AppT ListT t) = [| API.TList $(convertType t) |]+convertType (AppT (ConT con) t)+ | "Maybe" <- nameBase con = [| API.TMaybe $(convertType t) |]+ | otherwise = fail $ "Unsupported constructor in type: " ++ show t convertType t = fail $ "Unsupported type: " ++ show t convertType' :: Type -> Q API.Type@@ -55,6 +58,9 @@ | "Double" <- nameBase name = return $ API.TDouble | otherwise = return $ API.THaskell (T.pack $ nameBase name) convertType' (AppT ListT t) = API.TList `fmap` convertType' t+convertType' (AppT (ConT con) t)+ | "Maybe" <- nameBase con = API.TMaybe `fmap` convertType' t+ | otherwise = fail $ "Unsupported constructor in type: " ++ show t convertType' t = fail $ "Unsupported type: " ++ show t testHello :: String -> IO String
Test/Client.hs view
@@ -3,6 +3,7 @@ module Test.Client where import GHC.Generics+import Control.Monad.IO.Class import Data.Maybe import qualified Data.Map as M import qualified Data.Text as T
yaml-rpc.cabal view
@@ -1,6 +1,6 @@ Name: yaml-rpc -Version: 1.0.1+Version: 1.0.2 -- A short (one-line) description of the package. Synopsis: Simple library for network (HTTP REST-like) YAML RPC