├── .gitignore ├── .travis.yml ├── README.md ├── cabal.project ├── cabal.project.floor-ghc-7.8.4 ├── msgpack-aeson ├── LICENSE ├── Setup.hs ├── msgpack-aeson.cabal ├── src │ └── Data │ │ └── MessagePack │ │ └── Aeson.hs └── test │ └── test.hs ├── msgpack-idl-web ├── LICENSE ├── config │ ├── favicon.ico │ ├── models │ ├── robots.txt │ ├── routes │ ├── settings.yml │ └── sqlite.yml ├── deploy │ └── Procfile ├── messages │ └── en.msg ├── mpidl-web.cabal ├── src │ ├── Application.hs │ ├── Foundation.hs │ ├── Handler │ │ └── Home.hs │ ├── Import.hs │ ├── Model.hs │ ├── Settings.hs │ ├── Settings │ │ ├── Development.hs │ │ └── StaticFiles.hs │ ├── devel.hs │ └── main.hs ├── static │ ├── css │ │ └── bootstrap.css │ └── img │ │ ├── glyphicons-halflings-white.png │ │ └── glyphicons-halflings.png ├── templates │ ├── default-layout-wrapper.hamlet │ ├── default-layout.hamlet │ ├── homepage.hamlet │ ├── homepage.julius │ ├── homepage.lucius │ └── normalize.lucius └── tests │ ├── HomeTest.hs │ └── main.hs ├── msgpack-idl ├── LICENSE ├── Language │ └── MessagePack │ │ ├── IDL.hs │ │ └── IDL │ │ ├── Check.hs │ │ ├── CodeGen │ │ ├── Cpp.hs │ │ ├── Erlang.hs │ │ ├── Haskell.hs │ │ ├── Java.hs │ │ ├── Perl.hs │ │ ├── Php.hs │ │ ├── Python.hs │ │ └── Ruby.hs │ │ ├── Internal.hs │ │ ├── Parser.hs │ │ └── Syntax.hs ├── README.md ├── Setup.hs ├── Specification.md ├── exec │ └── main.hs ├── mpidl.peggy ├── msgpack-idl.cabal └── test │ ├── TODO.txt │ ├── idls │ └── empty.idl │ └── test.hs ├── msgpack-rpc ├── LICENSE ├── Setup.hs ├── msgpack-rpc.cabal ├── src │ └── Network │ │ └── MessagePack │ │ ├── Client.hs │ │ └── Server.hs └── test │ └── test.hs └── msgpack ├── CHANGES.md ├── LICENSE ├── Setup.hs ├── msgpack.cabal ├── src ├── Compat │ ├── Binary.hs │ └── Prelude.hs └── Data │ ├── MessagePack.hs │ └── MessagePack │ ├── Assoc.hs │ ├── Generic.hs │ ├── Get.hs │ ├── Get │ └── Internal.hs │ ├── Integer.hs │ ├── Object.hs │ ├── Put.hs │ ├── Result.hs │ ├── Tags.hs │ └── Timestamp.hs └── test ├── DataCases.hs ├── Properties.hs ├── data ├── 10.nil.yaml ├── 11.bool.yaml ├── 12.binary.yaml ├── 20.number-positive.yaml ├── 21.number-negative.yaml ├── 22.number-float.yaml ├── 23.number-bignum.yaml ├── 30.string-ascii.yaml ├── 31.string-utf8.yaml ├── 32.string-emoji.yaml ├── 40.array.yaml ├── 41.map.yaml ├── 42.nested.yaml ├── 50.timestamp.yaml ├── 60.ext.yaml └── README.md └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *# 3 | *.o 4 | *.hi 5 | *.a 6 | *.exe 7 | cabal-dev/ 8 | /dist/ 9 | attic/ 10 | tmp/ 11 | *.aes 12 | /.stack-work/ 13 | /dist-newstyle/ 14 | /.ghc.environment.* 15 | /cabal.project.local 16 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # simplified haskell-ci Travis setup 2 | # see also https://github.com/haskell-CI/haskell-ci 3 | 4 | language: haskell 5 | sudo: enabled 6 | 7 | cache: 8 | directories: 9 | - $HOME/.cabal/store 10 | 11 | cabal: 2.4 12 | 13 | matrix: 14 | include: 15 | - ghc: "8.6.4" 16 | - ghc: "8.4.4" 17 | - ghc: "8.2.2" 18 | - ghc: "8.0.2" 19 | - ghc: "7.10.3" 20 | - ghc: "7.8.4" 21 | 22 | # configuration for testing with lower bounds 23 | - ghc: "7.8.4" 24 | env: 'PROJCONF=floor-ghc-7.8.4' 25 | 26 | install: 27 | - cabal --version 28 | - ghc --version 29 | 30 | script: 31 | - '[ -z "$PROJCONF" ] || cp -v "cabal.project.$PROJCONF" cabal.project.local' 32 | 33 | - cabal v2-update 34 | - cabal v2-build all 35 | - cabal v2-test all 36 | #- cabal check 37 | - cabal v2-sdist all 38 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | MessagePack for Haskell [![Build Status](https://travis-ci.org/msgpack/msgpack-haskell.svg?branch=master)](https://travis-ci.org/msgpack/msgpack-haskell) 2 | ======================= 3 | 4 | This is an implementation of [MessagePack](https://en.wikipedia.org/wiki/MessagePack) for [Haskell](https://www.haskell.org). 5 | 6 | It contains: 7 | 8 | * Serializer/Deserializer 9 | * RPC 10 | 11 | # Installation 12 | 13 | Execute following instructions: 14 | 15 | ~~~ {.bash} 16 | $ cabal update 17 | $ cabal install msgpack 18 | $ cabal install msgpack-rpc 19 | ~~~ 20 | 21 | # Documentation 22 | 23 | [Haddock](https://www.haskell.org/haddock) documentation can be found on Hackage: 24 | 25 | * 26 | * 27 | * 28 | * 29 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | tests: True 2 | 3 | packages: 4 | msgpack 5 | msgpack-aeson 6 | msgpack-rpc 7 | -- msgpack-idl 8 | -- msgpack-idl-web 9 | -------------------------------------------------------------------------------- /cabal.project.floor-ghc-7.8.4: -------------------------------------------------------------------------------- 1 | -- freeze file for validating lower bounds 2 | 3 | -- with-compiler: ghc-7.8.4 4 | constraints: bytestring installed 5 | , deepseq installed 6 | , binary installed 7 | , containers installed 8 | 9 | , mtl == 2.2.1 10 | , vector == 0.10.11.0 11 | , data-binary-ieee754 == 0.4.4 12 | , unordered-containers == 0.2.5.0 13 | , hashable == 1.1.2.4 14 | , text == 1.2.3.0 15 | , scientific == 0.3.2.0 16 | , aeson == 0.8.0.2 17 | , exceptions == 0.8 18 | , network == 2.6.0.0 19 | , monad-control == 1.0.0.0 20 | , conduit == 1.2.3.1 21 | , conduit-extra == 1.1.3.4 22 | , binary-conduit == 1.2.3 23 | -------------------------------------------------------------------------------- /msgpack-aeson/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Hideyuki Tanaka 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Hideyuki Tanaka nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /msgpack-aeson/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /msgpack-aeson/msgpack-aeson.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: msgpack-aeson 3 | version: 0.2.0.0 4 | 5 | synopsis: Aeson adapter for MessagePack 6 | description: Aeson adapter for MessagePack 7 | homepage: http://msgpack.org/ 8 | bug-reports: https://github.com/msgpack/msgpack-haskell/issues 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Hideyuki Tanaka 12 | maintainer: Herbert Valerio Riedel 13 | copyright: (c) 2015 Hideyuki Tanaka 14 | category: Data 15 | build-type: Simple 16 | 17 | source-repository head 18 | type: git 19 | location: http://github.com/msgpack/msgpack-haskell.git 20 | subdir: msgpack-aeson 21 | 22 | library 23 | hs-source-dirs: src 24 | exposed-modules: Data.MessagePack.Aeson 25 | 26 | build-depends: base >= 4.7 && < 4.14 27 | , aeson >= 0.8.0.2 && < 0.12 28 | || >= 1.0 && < 1.5 29 | , bytestring >= 0.10.4 && < 0.11 30 | , msgpack >= 1.1.0 && < 1.2 31 | , scientific >= 0.3.2 && < 0.4 32 | , text >= 1.2.3 && < 1.3 33 | , unordered-containers >= 0.2.5 && < 0.3 34 | , vector >= 0.10.11 && < 0.13 35 | , deepseq >= 1.3 && < 1.5 36 | 37 | default-language: Haskell2010 38 | 39 | 40 | test-suite msgpack-aeson-test 41 | type: exitcode-stdio-1.0 42 | hs-source-dirs: test 43 | main-is: test.hs 44 | 45 | build-depends: msgpack-aeson 46 | -- inherited constraints via `msgpack-aeson` 47 | , base 48 | , aeson 49 | , msgpack 50 | -- test-specific dependencies 51 | , tasty == 1.2.* 52 | , tasty-hunit == 0.10.* 53 | 54 | default-language: Haskell2010 55 | -------------------------------------------------------------------------------- /msgpack-aeson/src/Data/MessagePack/Aeson.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | -- | Aeson bridge for MessagePack 8 | module Data.MessagePack.Aeson ( 9 | -- * Conversion functions 10 | toAeson, fromAeson, 11 | unsafeViaToJSON, viaFromJSON, 12 | 13 | -- * Wrapper instances 14 | AsMessagePack(..), 15 | AsAeson(..), 16 | MessagePackAesonError(..), 17 | 18 | -- * Utility functions 19 | packAeson, unpackAeson, 20 | decodeMessagePack, encodeMessagePack, 21 | ) where 22 | 23 | import Control.Applicative 24 | import Control.Arrow 25 | import Control.DeepSeq 26 | import Control.Exception 27 | import Data.Aeson as A 28 | import qualified Data.ByteString.Lazy as L (ByteString) 29 | import Data.Data 30 | import qualified Data.HashMap.Strict as HM 31 | import Data.Int 32 | import Data.Maybe 33 | import Data.MessagePack as MP 34 | import Data.MessagePack.Integer 35 | import Data.Scientific 36 | import qualified Data.Text.Encoding as T 37 | import Data.Traversable (traverse) 38 | import qualified Data.Vector as V 39 | import Data.Word 40 | 41 | -- | Convert 'MP.Object' to JSON 'Value' 42 | toAeson :: MP.Object -> A.Result Value 43 | toAeson = \case 44 | ObjectNil -> pure Null 45 | ObjectBool b -> pure (Bool b) 46 | ObjectInt n -> pure $! Number $! fromIntegral n 47 | ObjectFloat f -> pure $! Number $! realToFrac f 48 | ObjectDouble d -> pure $! Number $! realToFrac d 49 | ObjectStr t -> pure (String t) 50 | ObjectBin b -> fail $ "ObjectBin is not supported by JSON" 51 | ObjectArray v -> Array <$> V.mapM toAeson v 52 | ObjectMap m -> 53 | A.Object . HM.fromList . V.toList 54 | <$> V.mapM (\(k, v) -> (,) <$> from k <*> toAeson v) m 55 | where from = mpResult fail pure . MP.fromObject 56 | ObjectExt _ _ -> fail "ObjectExt is not supported by JSON" 57 | 58 | -- | Convert JSON 'Value' to 'MP.Object' 59 | fromAeson :: Value -> MP.Result MP.Object 60 | fromAeson = \case 61 | Null -> pure ObjectNil 62 | Bool b -> pure $ ObjectBool b 63 | Number s -> 64 | -- NOTE floatingOrInteger can OOM on untrusted input 65 | case floatingOrInteger s of 66 | Left n -> pure $ ObjectDouble n 67 | Right (fromIntegerTry -> Right n) -> pure $ ObjectInt n 68 | Right _ -> fail "number out of bounds" 69 | String t -> pure $ ObjectStr t 70 | Array v -> ObjectArray <$> traverse fromAeson v 71 | A.Object o -> (ObjectMap . V.fromList) <$> traverse fromEntry (HM.toList o) 72 | where 73 | fromEntry (k, v) = (\a -> (ObjectStr k, a)) <$> fromAeson v 74 | 75 | -- Helpers to piggyback off a JSON encoder / decoder when creating a MessagePack 76 | -- instance. 77 | -- 78 | -- Not as efficient as a direct encoder. 79 | viaFromJSON :: FromJSON a => MP.Object -> MP.Result a 80 | viaFromJSON o = case toAeson o >>= fromJSON of 81 | A.Success a -> MP.Success a 82 | A.Error e -> MP.Error e 83 | 84 | -- WARNING: not total for JSON numbers outside the 64 bit range 85 | unsafeViaToJSON :: ToJSON a => a -> MP.Object 86 | unsafeViaToJSON a = case fromAeson $ toJSON a of 87 | MP.Error e -> throw $ MessagePackAesonError e 88 | MP.Success a -> a 89 | 90 | data MessagePackAesonError = MessagePackAesonError String 91 | deriving (Eq, Show, Typeable) 92 | instance Exception MessagePackAesonError 93 | 94 | -- | Wrapper for using Aeson values as MessagePack value. 95 | newtype AsMessagePack a = AsMessagePack { getAsMessagePack :: a } 96 | deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) 97 | 98 | instance (FromJSON a, ToJSON a) => MessagePack (AsMessagePack a) where 99 | fromObject o = AsMessagePack <$> (aResult fail pure (fromJSON =<< toAeson o)) 100 | toObject = unsafeViaToJSON . getAsMessagePack 101 | 102 | -- | Wrapper for using MessagePack values as Aeson value. 103 | newtype AsAeson a = AsAeson { getAsAeson :: a } 104 | deriving (Eq, Ord, Show, Read, Functor, Data, Typeable, NFData) 105 | 106 | instance MessagePack a => ToJSON (AsAeson a) where 107 | toJSON = aResult (const Null) id . toAeson . toObject . getAsAeson 108 | 109 | instance MessagePack a => FromJSON (AsAeson a) where 110 | parseJSON j = case fromAeson j of 111 | MP.Error e -> fail e 112 | MP.Success a -> mpResult fail (pure . AsAeson) $ fromObject a 113 | 114 | -- | Encode to MessagePack via "Data.Aeson"'s 'ToJSON' instances 115 | packAeson :: ToJSON a => a -> MP.Result L.ByteString 116 | packAeson a = pack <$> (fromAeson $ toJSON a) 117 | 118 | -- | Decode from MessagePack via "Data.Aeson"'s 'FromJSON' instances 119 | unpackAeson :: FromJSON a => L.ByteString -> A.Result a 120 | unpackAeson b = fromJSON =<< toAeson =<< either fail pure (unpack b) 121 | 122 | -- | Encode MessagePack value to JSON document 123 | encodeMessagePack :: MessagePack a => a -> L.ByteString 124 | encodeMessagePack = encode . toJSON . AsAeson 125 | 126 | -- | Decode MessagePack value from JSON document 127 | decodeMessagePack :: MessagePack a => L.ByteString -> A.Result a 128 | decodeMessagePack b = getAsAeson <$> (fromJSON =<< either A.Error A.Success (eitherDecode b)) 129 | 130 | aResult f s = \case 131 | A.Success a -> s a 132 | A.Error e -> f e 133 | 134 | mpResult f s = \case 135 | MP.Success a -> s a 136 | MP.Error e -> f e 137 | -------------------------------------------------------------------------------- /msgpack-aeson/test/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | import Control.Applicative 6 | import Control.Monad 7 | import Data.Aeson as A 8 | import Data.Aeson.TH 9 | import Data.Int 10 | import Data.MessagePack as MP 11 | import Data.MessagePack.Aeson 12 | import Data.Word 13 | import GHC.Generics (Generic) 14 | import Test.Tasty 15 | import Test.Tasty.HUnit 16 | 17 | data T 18 | = A Int String 19 | | B Double 20 | deriving (Show, Eq, Generic) 21 | 22 | instance FromJSON T; instance ToJSON T 23 | 24 | data U 25 | = C { c1 :: Int, c2 :: String } 26 | | D { z1 :: Double } 27 | deriving (Show, Eq, Generic) 28 | 29 | instance FromJSON U; instance ToJSON U 30 | 31 | data V 32 | = E String | F 33 | deriving (Show, Eq, Generic) 34 | 35 | instance FromJSON V; instance ToJSON V 36 | 37 | data W a 38 | = G a String 39 | | H { hHoge :: Int, h_age :: a } 40 | deriving (Show, Eq, Generic) 41 | 42 | instance FromJSON a => FromJSON (W a); instance ToJSON a => ToJSON (W a) 43 | 44 | instance (FromJSON a, ToJSON a) => MessagePack (W a) where 45 | toObject = unsafeViaToJSON 46 | fromObject = viaFromJSON 47 | 48 | test :: (MessagePack a, Show a, Eq a) => a -> IO () 49 | test v = do 50 | let bs = pack v 51 | print bs 52 | print (unpack bs == Right v) 53 | 54 | let oa = toObject v 55 | print oa 56 | print (fromObject oa == MP.Success v) 57 | 58 | roundTrip :: (Show a, Eq a, ToJSON a, FromJSON a) => a -> IO () 59 | roundTrip v = do 60 | let mp = packAeson v 61 | v' = case mp of 62 | MP.Error e -> A.Error e 63 | MP.Success a -> unpackAeson a 64 | v' @?= pure v 65 | 66 | roundTrip' :: (Show a, Eq a, MessagePack a) => a -> IO () 67 | roundTrip' v = (unpack . pack $ v) @?= pure v 68 | 69 | main :: IO () 70 | main = 71 | defaultMain $ 72 | testGroup "test case" 73 | [ testCase "unnamed 1" $ 74 | roundTrip $ A 123 "hoge" 75 | , testCase "unnamed 2" $ 76 | roundTrip $ B 3.14 77 | , testCase "named 1" $ 78 | roundTrip $ C 123 "hoge" 79 | , testCase "named 2" $ 80 | roundTrip $ D 3.14 81 | , testCase "unit 1" $ 82 | roundTrip $ E "hello" 83 | , testCase "unit 2" $ 84 | roundTrip F 85 | , testCase "parameterized 1" $ 86 | roundTrip' $ G (E "hello") "world" 87 | , testCase "parameterized 2" $ 88 | roundTrip' $ H 123 F 89 | , testCase "negative numbers" $ 90 | roundTrip $ Number $ fromIntegral (minBound :: Int64) 91 | , testCase "positive numbers" $ 92 | roundTrip $ Number $ fromIntegral (maxBound :: Word64) 93 | , testCase "big negative" $ 94 | (fromAeson . Number $ -9223372036854775936) @?= (MP.Error "number out of bounds") 95 | , testCase "big positive" $ 96 | (fromAeson . Number $ 999223372036854775936) @?= (MP.Error "number out of bounds") 97 | , testCase "double precision" $ 98 | roundTrip . Number $ 10.0 99 | , testCase "really big integer" $ 100 | (fromAeson . Number $ read "1.0e999999") @?= (MP.Error "number out of bounds") 101 | -- high precision decimals silently lose precision 102 | ] 103 | -------------------------------------------------------------------------------- /msgpack-idl-web/LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2012, Hideyuki Tanaka. All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 19 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 22 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 23 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 24 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 25 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /msgpack-idl-web/config/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msgpack/msgpack-haskell/f52a5d2db620a7be70810eca648fd152141f8b14/msgpack-idl-web/config/favicon.ico -------------------------------------------------------------------------------- /msgpack-idl-web/config/models: -------------------------------------------------------------------------------- 1 | User 2 | ident Text 3 | password Text Maybe 4 | UniqueUser ident 5 | Email 6 | email Text 7 | user UserId Maybe 8 | verkey Text Maybe 9 | UniqueEmail email 10 | 11 | -- By default this file is used in Model.hs (which is imported by Foundation.hs) 12 | -------------------------------------------------------------------------------- /msgpack-idl-web/config/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /msgpack-idl-web/config/routes: -------------------------------------------------------------------------------- 1 | /static StaticR Static getStatic 2 | /auth AuthR Auth getAuth 3 | 4 | /favicon.ico FaviconR GET 5 | /robots.txt RobotsR GET 6 | 7 | / HomeR GET POST 8 | -------------------------------------------------------------------------------- /msgpack-idl-web/config/settings.yml: -------------------------------------------------------------------------------- 1 | Default: &defaults 2 | host: "*4" # any IPv4 host 3 | port: 3000 4 | approot: "http://192.168.0.70:3000" 5 | copyright: Insert copyright statement here 6 | #analytics: UA-YOURCODE 7 | 8 | Development: 9 | <<: *defaults 10 | 11 | Testing: 12 | port: 3334 13 | approot: "http://office.pfidev.jp/mpidl" 14 | <<: *defaults 15 | 16 | Staging: 17 | <<: *defaults 18 | 19 | Production: 20 | #approot: "http://www.example.com" 21 | <<: *defaults 22 | -------------------------------------------------------------------------------- /msgpack-idl-web/config/sqlite.yml: -------------------------------------------------------------------------------- 1 | Default: &defaults 2 | database: mpidl-web.sqlite3 3 | poolsize: 10 4 | 5 | Development: 6 | <<: *defaults 7 | 8 | Testing: 9 | database: mpidl-web_test.sqlite3 10 | <<: *defaults 11 | 12 | Staging: 13 | database: mpidl-web_staging.sqlite3 14 | poolsize: 100 15 | <<: *defaults 16 | 17 | Production: 18 | database: mpidl-web_production.sqlite3 19 | poolsize: 100 20 | <<: *defaults 21 | -------------------------------------------------------------------------------- /msgpack-idl-web/deploy/Procfile: -------------------------------------------------------------------------------- 1 | # Free deployment to Heroku. 2 | # 3 | # !! Warning: You must use a 64 bit machine to compile !! 4 | # 5 | # This could mean using a virtual machine. Give your VM as much memory as you can to speed up linking. 6 | # 7 | # Basic Yesod setup: 8 | # 9 | # * Move this file out of the deploy directory and into your root directory 10 | # 11 | # mv deploy/Procfile ./ 12 | # 13 | # * Create an empty package.json 14 | # echo '{ "name": "mpidl-web", "version": "0.0.1", "dependencies": {} }' >> package.json 15 | # 16 | # Postgresql Yesod setup: 17 | # 18 | # * add a dependency on the "heroku" package in your cabal file 19 | # 20 | # * add code in Application.hs to use the heroku package and load the connection parameters. 21 | # The below works for Postgresql. 22 | # 23 | # #ifndef DEVELOPMENT 24 | # import qualified Web.Heroku 25 | # #endif 26 | # 27 | # 28 | # makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application 29 | # makeApplication conf logger = do 30 | # manager <- newManager def 31 | # s <- staticSite 32 | # hconfig <- loadHerokuConfig 33 | # dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf) 34 | # (Database.Persist.Store.loadConfig . combineMappings hconfig) >>= 35 | # Database.Persist.Store.applyEnv 36 | # p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig) 37 | # Database.Persist.Store.runPool dbconf (runMigration migrateAll) p 38 | # let foundation = App conf setLogger s p manager dbconf 39 | # app <- toWaiAppPlain foundation 40 | # return $ logWare app 41 | # where 42 | ##ifdef DEVELOPMENT 43 | # logWare = logCallbackDev (logBS setLogger) 44 | # setLogger = logger 45 | ##else 46 | # setLogger = toProduction logger -- by default the logger is set for development 47 | # logWare = logCallback (logBS setLogger) 48 | ##endif 49 | # 50 | # #ifndef DEVELOPMENT 51 | # canonicalizeKey :: (Text, val) -> (Text, val) 52 | # canonicalizeKey ("dbname", val) = ("database", val) 53 | # canonicalizeKey pair = pair 54 | # 55 | # toMapping :: [(Text, Text)] -> AT.Value 56 | # toMapping xs = AT.Object $ M.fromList $ map (\(key, val) -> (key, AT.String val)) xs 57 | # #endif 58 | # 59 | # combineMappings :: AT.Value -> AT.Value -> AT.Value 60 | # combineMappings (AT.Object m1) (AT.Object m2) = AT.Object $ m1 `M.union` m2 61 | # combineMappings _ _ = error "Data.Object is not a Mapping." 62 | # 63 | # loadHerokuConfig :: IO AT.Value 64 | # loadHerokuConfig = do 65 | # #ifdef DEVELOPMENT 66 | # return $ AT.Object M.empty 67 | # #else 68 | # Web.Heroku.dbConnParams >>= return . toMapping . map canonicalizeKey 69 | # #endif 70 | 71 | 72 | 73 | # Heroku setup: 74 | # Find the Heroku guide. Roughly: 75 | # 76 | # * sign up for a heroku account and register your ssh key 77 | # * create a new application on the *cedar* stack 78 | # 79 | # * make your Yesod project the git repository for that application 80 | # * create a deploy branch 81 | # 82 | # git checkout -b deploy 83 | # 84 | # Repeat these steps to deploy: 85 | # * add your web executable binary (referenced below) to the git repository 86 | # 87 | # git checkout deploy 88 | # git add ./dist/build/mpidl-web/mpidl-web 89 | # git commit -m deploy 90 | # 91 | # * push to Heroku 92 | # 93 | # git push heroku deploy:master 94 | 95 | 96 | # Heroku configuration that runs your app 97 | web: ./dist/build/mpidl-web/mpidl-web production -p $PORT 98 | -------------------------------------------------------------------------------- /msgpack-idl-web/messages/en.msg: -------------------------------------------------------------------------------- 1 | Hello: Hello 2 | -------------------------------------------------------------------------------- /msgpack-idl-web/mpidl-web.cabal: -------------------------------------------------------------------------------- 1 | name: mpidl-web 2 | version: 0.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Hideyuki Tanaka 6 | maintainer: Hideyuki Tanaka 7 | synopsis: The greatest Yesod web application ever. 8 | description: I'm sure you can say something clever here if you try. 9 | category: Web 10 | stability: Experimental 11 | cabal-version: >= 1.8 12 | build-type: Simple 13 | homepage: http://mpidl-web.yesodweb.com/ 14 | 15 | Flag dev 16 | Description: Turn on development settings, like auto-reload templates. 17 | Default: False 18 | 19 | Flag library-only 20 | Description: Build for use with "yesod devel" 21 | Default: False 22 | 23 | library 24 | exposed-modules: Application 25 | Foundation 26 | Import 27 | Model 28 | Settings 29 | Settings.StaticFiles 30 | Settings.Development 31 | Handler.Home 32 | 33 | if flag(dev) || flag(library-only) 34 | cpp-options: -DDEVELOPMENT 35 | ghc-options: -Wall -threaded -O0 36 | else 37 | ghc-options: -Wall -threaded -O2 38 | 39 | extensions: TemplateHaskell 40 | QuasiQuotes 41 | OverloadedStrings 42 | NoImplicitPrelude 43 | CPP 44 | MultiParamTypeClasses 45 | TypeFamilies 46 | GADTs 47 | GeneralizedNewtypeDeriving 48 | FlexibleContexts 49 | EmptyDataDecls 50 | NoMonomorphismRestriction 51 | 52 | build-depends: base >= 4 && < 5 53 | , yesod-platform >= 1.0 && < 1.1 54 | , yesod >= 1.0 && < 1.1 55 | , yesod-core >= 1.0 && < 1.1 56 | , yesod-auth >= 1.0 && < 1.1 57 | , yesod-static >= 1.0 && < 1.1 58 | , yesod-default >= 1.0 && < 1.1 59 | , yesod-form >= 1.0 && < 1.1 60 | , yesod-test >= 0.2 && < 0.3 61 | , clientsession >= 0.7.3 && < 0.8 62 | , bytestring >= 0.9 && < 0.10 63 | , text >= 0.11 && < 0.12 64 | , persistent >= 0.9 && < 0.10 65 | , persistent-sqlite >= 0.9 && < 0.10 66 | , template-haskell 67 | , hamlet >= 1.0 && < 1.1 68 | , shakespeare-css >= 1.0 && < 1.1 69 | , shakespeare-js >= 1.0 && < 1.1 70 | , shakespeare-text >= 1.0 && < 1.1 71 | , hjsmin >= 0.1 && < 0.2 72 | , monad-control >= 0.3 && < 0.4 73 | , wai-extra >= 1.2 && < 1.3 74 | , yaml >= 0.7 && < 0.8 75 | , http-conduit >= 1.4 && < 1.5 76 | , directory >= 1.1 && < 1.2 77 | , warp >= 1.2 && < 1.3 78 | 79 | , shelly 80 | , bytestring 81 | , system-fileio 82 | 83 | executable mpidl-web 84 | if flag(library-only) 85 | Buildable: False 86 | 87 | main-is: main.hs 88 | hs-source-dirs: src 89 | build-depends: base 90 | , mpidl-web 91 | , yesod-default 92 | 93 | test-suite test 94 | type: exitcode-stdio-1.0 95 | main-is: main.hs 96 | hs-source-dirs: tests 97 | ghc-options: -Wall 98 | extensions: TemplateHaskell 99 | QuasiQuotes 100 | OverloadedStrings 101 | NoImplicitPrelude 102 | CPP 103 | OverloadedStrings 104 | MultiParamTypeClasses 105 | TypeFamilies 106 | GADTs 107 | GeneralizedNewtypeDeriving 108 | FlexibleContexts 109 | 110 | build-depends: base 111 | , mpidl-web 112 | , yesod-test 113 | , yesod-default 114 | , yesod-core 115 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | module Application 3 | ( makeApplication 4 | , getApplicationDev 5 | , makeFoundation 6 | ) where 7 | 8 | import Import 9 | import Settings 10 | import Yesod.Auth 11 | import Yesod.Default.Config 12 | import Yesod.Default.Main 13 | import Yesod.Default.Handlers 14 | import Yesod.Logger (Logger, logBS, toProduction) 15 | import Network.Wai.Middleware.RequestLogger (logCallback, logCallbackDev) 16 | import qualified Database.Persist.Store 17 | import Database.Persist.GenericSql (runMigration) 18 | import Network.HTTP.Conduit (newManager, def) 19 | 20 | -- Import all relevant handler modules here. 21 | -- Don't forget to add new modules to your cabal file! 22 | import Handler.Home 23 | 24 | -- This line actually creates our YesodSite instance. It is the second half 25 | -- of the call to mkYesodData which occurs in Foundation.hs. Please see 26 | -- the comments there for more details. 27 | mkYesodDispatch "App" resourcesApp 28 | 29 | -- This function allocates resources (such as a database connection pool), 30 | -- performs initialization and creates a WAI application. This is also the 31 | -- place to put your migrate statements to have automatic database 32 | -- migrations handled by Yesod. 33 | makeApplication :: AppConfig DefaultEnv Extra -> Logger -> IO Application 34 | makeApplication conf logger = do 35 | foundation <- makeFoundation conf setLogger 36 | app <- toWaiAppPlain foundation 37 | return $ logWare app 38 | where 39 | setLogger = if development then logger else toProduction logger 40 | logWare = if development then logCallbackDev (logBS setLogger) 41 | else logCallback (logBS setLogger) 42 | 43 | makeFoundation :: AppConfig DefaultEnv Extra -> Logger -> IO App 44 | makeFoundation conf setLogger = do 45 | manager <- newManager def 46 | s <- staticSite 47 | dbconf <- withYamlEnvironment "config/sqlite.yml" (appEnv conf) 48 | Database.Persist.Store.loadConfig >>= 49 | Database.Persist.Store.applyEnv 50 | p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig) 51 | Database.Persist.Store.runPool dbconf (runMigration migrateAll) p 52 | return $ App conf setLogger s p manager dbconf 53 | 54 | -- for yesod devel 55 | getApplicationDev :: IO (Int, Application) 56 | getApplicationDev = 57 | defaultDevelApp loader makeApplication 58 | where 59 | loader = loadConfig (configSettings Development) 60 | { csParseExtra = parseExtra 61 | } 62 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Foundation.hs: -------------------------------------------------------------------------------- 1 | module Foundation 2 | ( App (..) 3 | , Route (..) 4 | , AppMessage (..) 5 | , resourcesApp 6 | , Handler 7 | , Widget 8 | , Form 9 | , maybeAuth 10 | , requireAuth 11 | , module Settings 12 | , module Model 13 | ) where 14 | 15 | import Prelude 16 | import Yesod 17 | import Yesod.Static 18 | import Yesod.Auth 19 | import Yesod.Auth.BrowserId 20 | import Yesod.Auth.GoogleEmail 21 | import Yesod.Default.Config 22 | import Yesod.Default.Util (addStaticContentExternal) 23 | import Yesod.Logger (Logger, logMsg, formatLogText) 24 | import Network.HTTP.Conduit (Manager) 25 | import qualified Settings 26 | import qualified Database.Persist.Store 27 | import Settings.StaticFiles 28 | import Database.Persist.GenericSql 29 | import Settings (widgetFile, Extra (..)) 30 | import Model 31 | import Text.Jasmine (minifym) 32 | import Web.ClientSession (getKey) 33 | import Text.Hamlet (hamletFile) 34 | 35 | -- | The site argument for your application. This can be a good place to 36 | -- keep settings and values requiring initialization before your application 37 | -- starts running, such as database connections. Every handler will have 38 | -- access to the data present here. 39 | data App = App 40 | { settings :: AppConfig DefaultEnv Extra 41 | , getLogger :: Logger 42 | , getStatic :: Static -- ^ Settings for static file serving. 43 | , connPool :: Database.Persist.Store.PersistConfigPool Settings.PersistConfig -- ^ Database connection pool. 44 | , httpManager :: Manager 45 | , persistConfig :: Settings.PersistConfig 46 | } 47 | 48 | -- Set up i18n messages. See the message folder. 49 | mkMessage "App" "messages" "en" 50 | 51 | -- This is where we define all of the routes in our application. For a full 52 | -- explanation of the syntax, please see: 53 | -- http://www.yesodweb.com/book/handler 54 | -- 55 | -- This function does three things: 56 | -- 57 | -- * Creates the route datatype AppRoute. Every valid URL in your 58 | -- application can be represented as a value of this type. 59 | -- * Creates the associated type: 60 | -- type instance Route App = AppRoute 61 | -- * Creates the value resourcesApp which contains information on the 62 | -- resources declared below. This is used in Handler.hs by the call to 63 | -- mkYesodDispatch 64 | -- 65 | -- What this function does *not* do is create a YesodSite instance for 66 | -- App. Creating that instance requires all of the handler functions 67 | -- for our application to be in scope. However, the handler functions 68 | -- usually require access to the AppRoute datatype. Therefore, we 69 | -- split these actions into two functions and place them in separate files. 70 | mkYesodData "App" $(parseRoutesFile "config/routes") 71 | 72 | type Form x = Html -> MForm App App (FormResult x, Widget) 73 | 74 | -- Please see the documentation for the Yesod typeclass. There are a number 75 | -- of settings which can be configured by overriding methods here. 76 | instance Yesod App where 77 | approot = ApprootMaster $ appRoot . settings 78 | 79 | -- Store session data on the client in encrypted cookies, 80 | -- default session idle timeout is 120 minutes 81 | makeSessionBackend _ = do 82 | key <- getKey "config/client_session_key.aes" 83 | return . Just $ clientSessionBackend key 120 84 | 85 | defaultLayout widget = do 86 | master <- getYesod 87 | mmsg <- getMessage 88 | 89 | -- We break up the default layout into two components: 90 | -- default-layout is the contents of the body tag, and 91 | -- default-layout-wrapper is the entire page. Since the final 92 | -- value passed to hamletToRepHtml cannot be a widget, this allows 93 | -- you to use normal widget features in default-layout. 94 | 95 | pc <- widgetToPageContent $ do 96 | $(widgetFile "normalize") 97 | addStylesheet $ StaticR css_bootstrap_css 98 | $(widgetFile "default-layout") 99 | hamletToRepHtml $(hamletFile "templates/default-layout-wrapper.hamlet") 100 | 101 | -- This is done to provide an optimization for serving static files from 102 | -- a separate domain. Please see the staticRoot setting in Settings.hs 103 | urlRenderOverride y (StaticR s) = 104 | Just $ uncurry (joinPath y (Settings.staticRoot $ settings y)) $ renderRoute s 105 | urlRenderOverride _ _ = Nothing 106 | 107 | -- The page to be redirected to when authentication is required. 108 | authRoute _ = Just $ AuthR LoginR 109 | 110 | messageLogger y loc level msg = 111 | formatLogText (getLogger y) loc level msg >>= logMsg (getLogger y) 112 | 113 | -- This function creates static content files in the static folder 114 | -- and names them based on a hash of their content. This allows 115 | -- expiration dates to be set far in the future without worry of 116 | -- users receiving stale content. 117 | addStaticContent = addStaticContentExternal minifym base64md5 Settings.staticDir (StaticR . flip StaticRoute []) 118 | 119 | -- Place Javascript at bottom of the body tag so the rest of the page loads first 120 | jsLoader _ = BottomOfBody 121 | 122 | -- How to run database actions. 123 | instance YesodPersist App where 124 | type YesodPersistBackend App = SqlPersist 125 | runDB f = do 126 | master <- getYesod 127 | Database.Persist.Store.runPool 128 | (persistConfig master) 129 | f 130 | (connPool master) 131 | 132 | instance YesodAuth App where 133 | type AuthId App = UserId 134 | 135 | -- Where to send a user after successful login 136 | loginDest _ = HomeR 137 | -- Where to send a user after logout 138 | logoutDest _ = HomeR 139 | 140 | getAuthId creds = runDB $ do 141 | x <- getBy $ UniqueUser $ credsIdent creds 142 | case x of 143 | Just (Entity uid _) -> return $ Just uid 144 | Nothing -> do 145 | fmap Just $ insert $ User (credsIdent creds) Nothing 146 | 147 | -- You can add other plugins like BrowserID, email or OAuth here 148 | authPlugins _ = [authBrowserId, authGoogleEmail] 149 | 150 | authHttpManager = httpManager 151 | 152 | -- This instance is required to use forms. You can modify renderMessage to 153 | -- achieve customized and internationalized form validation messages. 154 | instance RenderMessage App FormMessage where 155 | renderMessage _ _ = defaultFormMessage 156 | 157 | -- Note: previous versions of the scaffolding included a deliver function to 158 | -- send emails. Unfortunately, there are too many different options for us to 159 | -- give a reasonable default. Instead, the information is available on the 160 | -- wiki: 161 | -- 162 | -- https://github.com/yesodweb/yesod/wiki/Sending-email 163 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Handler/Home.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections, OverloadedStrings, ViewPatterns #-} 2 | module Handler.Home where 3 | 4 | import Import 5 | 6 | import Data.Maybe 7 | import qualified Data.Text.Lazy as LT 8 | import qualified Filesystem as FS 9 | import Shelly 10 | import Text.Shakespeare.Text 11 | 12 | defaultCode :: Text 13 | defaultCode = [st| 14 | message hoge { 15 | 0: int moge 16 | 1: map hage 17 | } 18 | 19 | service test { 20 | void foo(0: hoge x) 21 | } 22 | |] 23 | 24 | getHomeR :: Handler RepHtml 25 | getHomeR = do 26 | let submission = Nothing :: Maybe (FileInfo, Text) 27 | handlerName = "getHomeR" :: Text 28 | defaultLayout $ do 29 | aDomId <- lift newIdent 30 | setTitle "MessagePack IDL Code Generator" 31 | $(widgetFile "homepage") 32 | 33 | postHomeR :: Handler (ContentType, Content) 34 | postHomeR = do 35 | (fromMaybe "noname" -> name, source, lang, namespace) <- runInputPost $ (,,,) 36 | <$> iopt textField "name" 37 | <*> ireq textField "source" 38 | <*> ireq textField "lang" 39 | <*> iopt textField "namespace" 40 | 41 | let tarname = [lt|#{name}.tar.bz2|] 42 | idlname = [lt|#{name}.idl|] 43 | 44 | let opts = map LT.fromStrict $ case (lang, namespace) of 45 | ("cpp", Just ns) -> ["-n", ns] 46 | ("java", Just pn) -> ["-p", pn] 47 | ("ruby", Just mn) -> ["-m", mn] 48 | _ -> [] 49 | 50 | archive <- shelly $ do 51 | withTmpDir $ \tmppath -> chdir tmppath $ do 52 | writefile (fromText idlname) $ LT.fromStrict source 53 | run_ "mpidl" $ [LT.fromStrict lang, "-o", [lt|#{name}|], idlname] ++ opts 54 | run_ "tar" ["-cjf", tarname, [lt|#{name}|]] 55 | p <- pwd 56 | liftIO $ FS.readFile $ p fromText tarname 57 | 58 | setHeader "Content-Disposition" [st|attachment; filename="#{tarname}"|] 59 | return ("application/x-bz2", toContent archive) 60 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module Prelude 3 | , module Yesod 4 | , module Foundation 5 | , module Settings.StaticFiles 6 | , module Settings.Development 7 | , module Data.Monoid 8 | , module Control.Applicative 9 | , Text 10 | #if __GLASGOW_HASKELL__ < 704 11 | , (<>) 12 | #endif 13 | ) where 14 | 15 | import Prelude hiding (writeFile, readFile, head, tail, init, last) 16 | import Yesod hiding (Route(..)) 17 | import Foundation 18 | import Data.Monoid (Monoid (mappend, mempty, mconcat)) 19 | import Control.Applicative ((<$>), (<*>), pure) 20 | import Data.Text (Text) 21 | import Settings.StaticFiles 22 | import Settings.Development 23 | 24 | #if __GLASGOW_HASKELL__ < 704 25 | infixr 5 <> 26 | (<>) :: Monoid m => m -> m -> m 27 | (<>) = mappend 28 | #endif 29 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Model.hs: -------------------------------------------------------------------------------- 1 | module Model where 2 | 3 | import Prelude 4 | import Yesod 5 | import Data.Text (Text) 6 | import Database.Persist.Quasi 7 | 8 | 9 | -- You can define all of your database entities in the entities file. 10 | -- You can find more information on persistent and how to declare entities 11 | -- at: 12 | -- http://www.yesodweb.com/book/persistent/ 13 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] 14 | $(persistFileWith lowerCaseSettings "config/models") 15 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Settings.hs: -------------------------------------------------------------------------------- 1 | -- | Settings are centralized, as much as possible, into this file. This 2 | -- includes database connection settings, static file locations, etc. 3 | -- In addition, you can configure a number of different aspects of Yesod 4 | -- by overriding methods in the Yesod typeclass. That instance is 5 | -- declared in the Foundation.hs file. 6 | module Settings 7 | ( widgetFile 8 | , PersistConfig 9 | , staticRoot 10 | , staticDir 11 | , Extra (..) 12 | , parseExtra 13 | ) where 14 | 15 | import Prelude 16 | import Text.Shakespeare.Text (st) 17 | import Language.Haskell.TH.Syntax 18 | import Database.Persist.Sqlite (SqliteConf) 19 | import Yesod.Default.Config 20 | import qualified Yesod.Default.Util 21 | import Data.Text (Text) 22 | import Data.Yaml 23 | import Control.Applicative 24 | import Settings.Development 25 | 26 | -- | Which Persistent backend this site is using. 27 | type PersistConfig = SqliteConf 28 | 29 | -- Static setting below. Changing these requires a recompile 30 | 31 | -- | The location of static files on your system. This is a file system 32 | -- path. The default value works properly with your scaffolded site. 33 | staticDir :: FilePath 34 | staticDir = "static" 35 | 36 | -- | The base URL for your static files. As you can see by the default 37 | -- value, this can simply be "static" appended to your application root. 38 | -- A powerful optimization can be serving static files from a separate 39 | -- domain name. This allows you to use a web server optimized for static 40 | -- files, more easily set expires and cache values, and avoid possibly 41 | -- costly transference of cookies on static files. For more information, 42 | -- please see: 43 | -- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain 44 | -- 45 | -- If you change the resource pattern for StaticR in Foundation.hs, you will 46 | -- have to make a corresponding change here. 47 | -- 48 | -- To see how this value is used, see urlRenderOverride in Foundation.hs 49 | staticRoot :: AppConfig DefaultEnv x -> Text 50 | staticRoot conf = [st|#{appRoot conf}/static|] 51 | 52 | 53 | -- The rest of this file contains settings which rarely need changing by a 54 | -- user. 55 | 56 | widgetFile :: String -> Q Exp 57 | widgetFile = if development then Yesod.Default.Util.widgetFileReload 58 | else Yesod.Default.Util.widgetFileNoReload 59 | 60 | data Extra = Extra 61 | { extraCopyright :: Text 62 | , extraAnalytics :: Maybe Text -- ^ Google Analytics 63 | } deriving Show 64 | 65 | parseExtra :: DefaultEnv -> Object -> Parser Extra 66 | parseExtra _ o = Extra 67 | <$> o .: "copyright" 68 | <*> o .:? "analytics" 69 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Settings/Development.hs: -------------------------------------------------------------------------------- 1 | module Settings.Development where 2 | 3 | import Prelude 4 | 5 | development :: Bool 6 | development = 7 | #if DEVELOPMENT 8 | True 9 | #else 10 | False 11 | #endif 12 | 13 | production :: Bool 14 | production = not development 15 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/Settings/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | module Settings.StaticFiles where 2 | 3 | import Prelude (IO) 4 | import Yesod.Static 5 | import qualified Yesod.Static as Static 6 | import Settings (staticDir) 7 | import Settings.Development 8 | 9 | -- | use this to create your static file serving site 10 | staticSite :: IO Static.Static 11 | staticSite = if development then Static.staticDevel staticDir 12 | else Static.static staticDir 13 | 14 | -- | This generates easy references to files in the static directory at compile time, 15 | -- giving you compile-time verification that referenced files exist. 16 | -- Warning: any files added to your static directory during run-time can't be 17 | -- accessed this way. You'll have to use their FilePath or URL to access them. 18 | $(staticFiles Settings.staticDir) 19 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "mpidl-web" Application (getApplicationDev) 3 | import Network.Wai.Handler.Warp 4 | (runSettings, defaultSettings, settingsPort) 5 | import Control.Concurrent (forkIO) 6 | import System.Directory (doesFileExist, removeFile) 7 | import System.Exit (exitSuccess) 8 | import Control.Concurrent (threadDelay) 9 | 10 | main :: IO () 11 | main = do 12 | putStrLn "Starting devel application" 13 | (port, app) <- getApplicationDev 14 | forkIO $ runSettings defaultSettings 15 | { settingsPort = port 16 | } app 17 | loop 18 | 19 | loop :: IO () 20 | loop = do 21 | threadDelay 100000 22 | e <- doesFileExist "dist/devel-terminate" 23 | if e then terminateDevel else loop 24 | 25 | terminateDevel :: IO () 26 | terminateDevel = exitSuccess 27 | -------------------------------------------------------------------------------- /msgpack-idl-web/src/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Yesod.Default.Config (fromArgs) 3 | import Yesod.Default.Main (defaultMain) 4 | import Settings (parseExtra) 5 | import Application (makeApplication) 6 | 7 | main :: IO () 8 | main = defaultMain (fromArgs parseExtra) makeApplication 9 | -------------------------------------------------------------------------------- /msgpack-idl-web/static/img/glyphicons-halflings-white.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msgpack/msgpack-haskell/f52a5d2db620a7be70810eca648fd152141f8b14/msgpack-idl-web/static/img/glyphicons-halflings-white.png -------------------------------------------------------------------------------- /msgpack-idl-web/static/img/glyphicons-halflings.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/msgpack/msgpack-haskell/f52a5d2db620a7be70810eca648fd152141f8b14/msgpack-idl-web/static/img/glyphicons-halflings.png -------------------------------------------------------------------------------- /msgpack-idl-web/templates/default-layout-wrapper.hamlet: -------------------------------------------------------------------------------- 1 | \ 2 | \ 3 | \ 4 | \ 5 | \ 6 | 7 | 8 | 9 | 10 | #{pageTitle pc} 11 | <meta name="description" content=""> 12 | <meta name="author" content=""> 13 | 14 | <meta name="viewport" content="width=device-width,initial-scale=1"> 15 | 16 | ^{pageHead pc} 17 | 18 | \<!--[if lt IE 9]> 19 | \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> 20 | \<![endif]--> 21 | 22 | <script> 23 | document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); 24 | <body> 25 | <div class="container"> 26 | <header> 27 | <div id="main" role="main"> 28 | ^{pageBody pc} 29 | <footer> 30 | #{extraCopyright $ appExtra $ settings master} 31 | 32 | $maybe analytics <- extraAnalytics $ appExtra $ settings master 33 | <script> 34 | if(!window.location.href.match(/localhost/)){ 35 | window._gaq = [['_setAccount','#{analytics}'],['_trackPageview'],['_trackPageLoadTime']]; 36 | (function() { 37 | \ var ga = document.createElement('script'); ga.type = 'text/javascript'; ga.async = true; 38 | \ ga.src = ('https:' == document.location.protocol ? 'https://ssl' : 'http://www') + '.google-analytics.com/ga.js'; 39 | \ var s = document.getElementsByTagName('script')[0]; s.parentNode.insertBefore(ga, s); 40 | })(); 41 | } 42 | \<!-- Prompt IE 6 users to install Chrome Frame. Remove this if you want to support IE 6. chromium.org/developers/how-tos/chrome-frame-getting-started --> 43 | \<!--[if lt IE 7 ]> 44 | <script src="//ajax.googleapis.com/ajax/libs/chrome-frame/1.0.3/CFInstall.min.js"> 45 | <script> 46 | window.attachEvent('onload',function(){CFInstall.check({mode:'overlay'})}) 47 | \<![endif]--> 48 | -------------------------------------------------------------------------------- /msgpack-idl-web/templates/default-layout.hamlet: -------------------------------------------------------------------------------- 1 | $maybe msg <- mmsg 2 | <div #message>#{msg} 3 | ^{widget} 4 | -------------------------------------------------------------------------------- /msgpack-idl-web/templates/homepage.hamlet: -------------------------------------------------------------------------------- 1 | <h1>MessagePack IDL Code Generator 2 | 3 | <form.well method=post action=@{HomeR}> 4 | <label>IDL Name 5 | <input type="text" name="name"> 6 | <label>IDL Source 7 | <textarea.input-xxlarge rows="20" name="source"> 8 | #{defaultCode} 9 | 10 | <label>Language to Generate 11 | <select name="lang"> 12 | <option value="cpp">C++ 13 | <option value="java">Java 14 | <option value="python">Python 15 | <option value="ruby">Ruby 16 | 17 | <label>Namespace / Package name / Module name 18 | <input type="text" name="namespace"> 19 | 20 | <button.btn type="submit">Generate 21 | -------------------------------------------------------------------------------- /msgpack-idl-web/templates/homepage.julius: -------------------------------------------------------------------------------- 1 | document.getElementById("#{aDomId}").innerHTML = "This text was added by the Javascript part of the homepage widget."; 2 | -------------------------------------------------------------------------------- /msgpack-idl-web/templates/homepage.lucius: -------------------------------------------------------------------------------- 1 | h1 { 2 | text-align: center 3 | } 4 | h2##{aDomId} { 5 | color: #990 6 | } 7 | -------------------------------------------------------------------------------- /msgpack-idl-web/templates/normalize.lucius: -------------------------------------------------------------------------------- 1 | /*! normalize.css 2011-08-12T17:28 UTC · http://github.com/necolas/normalize.css */ 2 | 3 | /* ============================================================================= 4 | HTML5 display definitions 5 | ========================================================================== */ 6 | 7 | /* 8 | * Corrects block display not defined in IE6/7/8/9 & FF3 9 | */ 10 | 11 | article, 12 | aside, 13 | details, 14 | figcaption, 15 | figure, 16 | footer, 17 | header, 18 | hgroup, 19 | nav, 20 | section { 21 | display: block; 22 | } 23 | 24 | /* 25 | * Corrects inline-block display not defined in IE6/7/8/9 & FF3 26 | */ 27 | 28 | audio, 29 | canvas, 30 | video { 31 | display: inline-block; 32 | *display: inline; 33 | *zoom: 1; 34 | } 35 | 36 | /* 37 | * Prevents modern browsers from displaying 'audio' without controls 38 | */ 39 | 40 | audio:not([controls]) { 41 | display: none; 42 | } 43 | 44 | /* 45 | * Addresses styling for 'hidden' attribute not present in IE7/8/9, FF3, S4 46 | * Known issue: no IE6 support 47 | */ 48 | 49 | [hidden] { 50 | display: none; 51 | } 52 | 53 | 54 | /* ============================================================================= 55 | Base 56 | ========================================================================== */ 57 | 58 | /* 59 | * 1. Corrects text resizing oddly in IE6/7 when body font-size is set using em units 60 | * http://clagnut.com/blog/348/#c790 61 | * 2. Keeps page centred in all browsers regardless of content height 62 | * 3. Prevents iOS text size adjust after orientation change, without disabling user zoom 63 | * www.456bereastreet.com/archive/201012/controlling_text_size_in_safari_for_ios_without_disabling_user_zoom/ 64 | */ 65 | 66 | html { 67 | font-size: 100%; /* 1 */ 68 | overflow-y: scroll; /* 2 */ 69 | -webkit-text-size-adjust: 100%; /* 3 */ 70 | -ms-text-size-adjust: 100%; /* 3 */ 71 | } 72 | 73 | /* 74 | * Addresses margins handled incorrectly in IE6/7 75 | */ 76 | 77 | body { 78 | margin: 0; 79 | } 80 | 81 | /* 82 | * Addresses font-family inconsistency between 'textarea' and other form elements. 83 | */ 84 | 85 | body, 86 | button, 87 | input, 88 | select, 89 | textarea { 90 | font-family: sans-serif; 91 | } 92 | 93 | 94 | /* ============================================================================= 95 | Links 96 | ========================================================================== */ 97 | 98 | a { 99 | color: #00e; 100 | } 101 | 102 | a:visited { 103 | color: #551a8b; 104 | } 105 | 106 | /* 107 | * Addresses outline displayed oddly in Chrome 108 | */ 109 | 110 | a:focus { 111 | outline: thin dotted; 112 | } 113 | 114 | /* 115 | * Improves readability when focused and also mouse hovered in all browsers 116 | * people.opera.com/patrickl/experiments/keyboard/test 117 | */ 118 | 119 | a:hover, 120 | a:active { 121 | outline: 0; 122 | } 123 | 124 | 125 | /* ============================================================================= 126 | Typography 127 | ========================================================================== */ 128 | 129 | /* 130 | * Addresses styling not present in IE7/8/9, S5, Chrome 131 | */ 132 | 133 | abbr[title] { 134 | border-bottom: 1px dotted; 135 | } 136 | 137 | /* 138 | * Addresses style set to 'bolder' in FF3/4, S4/5, Chrome 139 | */ 140 | 141 | b, 142 | strong { 143 | font-weight: bold; 144 | } 145 | 146 | blockquote { 147 | margin: 1em 40px; 148 | } 149 | 150 | /* 151 | * Addresses styling not present in S5, Chrome 152 | */ 153 | 154 | dfn { 155 | font-style: italic; 156 | } 157 | 158 | /* 159 | * Addresses styling not present in IE6/7/8/9 160 | */ 161 | 162 | mark { 163 | background: #ff0; 164 | color: #000; 165 | } 166 | 167 | /* 168 | * Corrects font family set oddly in IE6, S4/5, Chrome 169 | * en.wikipedia.org/wiki/User:Davidgothberg/Test59 170 | */ 171 | 172 | pre, 173 | code, 174 | kbd, 175 | samp { 176 | font-family: monospace, serif; 177 | _font-family: 'courier new', monospace; 178 | font-size: 1em; 179 | } 180 | 181 | /* 182 | * Improves readability of pre-formatted text in all browsers 183 | */ 184 | 185 | pre { 186 | white-space: pre; 187 | white-space: pre-wrap; 188 | word-wrap: break-word; 189 | } 190 | 191 | /* 192 | * 1. Addresses CSS quotes not supported in IE6/7 193 | * 2. Addresses quote property not supported in S4 194 | */ 195 | 196 | /* 1 */ 197 | 198 | q { 199 | quotes: none; 200 | } 201 | 202 | /* 2 */ 203 | 204 | q:before, 205 | q:after { 206 | content: ''; 207 | content: none; 208 | } 209 | 210 | small { 211 | font-size: 75%; 212 | } 213 | 214 | /* 215 | * Prevents sub and sup affecting line-height in all browsers 216 | * gist.github.com/413930 217 | */ 218 | 219 | sub, 220 | sup { 221 | font-size: 75%; 222 | line-height: 0; 223 | position: relative; 224 | vertical-align: baseline; 225 | } 226 | 227 | sup { 228 | top: -0.5em; 229 | } 230 | 231 | sub { 232 | bottom: -0.25em; 233 | } 234 | 235 | 236 | /* ============================================================================= 237 | Lists 238 | ========================================================================== */ 239 | 240 | ul, 241 | ol { 242 | margin: 1em 0; 243 | padding: 0 0 0 40px; 244 | } 245 | 246 | dd { 247 | margin: 0 0 0 40px; 248 | } 249 | 250 | nav ul, 251 | nav ol { 252 | list-style: none; 253 | list-style-image: none; 254 | } 255 | 256 | 257 | /* ============================================================================= 258 | Embedded content 259 | ========================================================================== */ 260 | 261 | /* 262 | * 1. Removes border when inside 'a' element in IE6/7/8/9 263 | * 2. Improves image quality when scaled in IE7 264 | * code.flickr.com/blog/2008/11/12/on-ui-quality-the-little-things-client-side-image-resizing/ 265 | */ 266 | 267 | img { 268 | border: 0; /* 1 */ 269 | -ms-interpolation-mode: bicubic; /* 2 */ 270 | } 271 | 272 | /* 273 | * Corrects overflow displayed oddly in IE9 274 | */ 275 | 276 | svg:not(:root) { 277 | overflow: hidden; 278 | } 279 | 280 | 281 | /* ============================================================================= 282 | Figures 283 | ========================================================================== */ 284 | 285 | /* 286 | * Addresses margin not present in IE6/7/8/9, S5, O11 287 | */ 288 | 289 | figure { 290 | margin: 0; 291 | } 292 | 293 | 294 | /* ============================================================================= 295 | Forms 296 | ========================================================================== */ 297 | 298 | /* 299 | * Corrects margin displayed oddly in IE6/7 300 | */ 301 | 302 | form { 303 | margin: 0; 304 | } 305 | 306 | /* 307 | * Define consistent margin and padding 308 | */ 309 | 310 | fieldset { 311 | margin: 0 2px; 312 | padding: 0.35em 0.625em 0.75em; 313 | } 314 | 315 | /* 316 | * 1. Corrects color not being inherited in IE6/7/8/9 317 | * 2. Corrects alignment displayed oddly in IE6/7 318 | */ 319 | 320 | legend { 321 | border: 0; /* 1 */ 322 | *margin-left: -7px; /* 2 */ 323 | } 324 | 325 | /* 326 | * 1. Corrects font size not being inherited in all browsers 327 | * 2. Addresses margins set differently in IE6/7, F3/4, S5, Chrome 328 | * 3. Improves appearance and consistency in all browsers 329 | */ 330 | 331 | button, 332 | input, 333 | select, 334 | textarea { 335 | font-size: 100%; /* 1 */ 336 | margin: 0; /* 2 */ 337 | vertical-align: baseline; /* 3 */ 338 | *vertical-align: middle; /* 3 */ 339 | } 340 | 341 | /* 342 | * 1. Addresses FF3/4 setting line-height using !important in the UA stylesheet 343 | * 2. Corrects inner spacing displayed oddly in IE6/7 344 | */ 345 | 346 | button, 347 | input { 348 | line-height: normal; /* 1 */ 349 | *overflow: visible; /* 2 */ 350 | } 351 | 352 | /* 353 | * Corrects overlap and whitespace issue for buttons and inputs in IE6/7 354 | * Known issue: reintroduces inner spacing 355 | */ 356 | 357 | table button, 358 | table input { 359 | *overflow: auto; 360 | } 361 | 362 | /* 363 | * 1. Improves usability and consistency of cursor style between image-type 'input' and others 364 | * 2. Corrects inability to style clickable 'input' types in iOS 365 | */ 366 | 367 | button, 368 | html input[type="button"], 369 | input[type="reset"], 370 | input[type="submit"] { 371 | cursor: pointer; /* 1 */ 372 | -webkit-appearance: button; /* 2 */ 373 | } 374 | 375 | /* 376 | * 1. Addresses box sizing set to content-box in IE8/9 377 | * 2. Addresses excess padding in IE8/9 378 | */ 379 | 380 | input[type="checkbox"], 381 | input[type="radio"] { 382 | box-sizing: border-box; /* 1 */ 383 | padding: 0; /* 2 */ 384 | } 385 | 386 | /* 387 | * 1. Addresses appearance set to searchfield in S5, Chrome 388 | * 2. Addresses box sizing set to border-box in S5, Chrome (include -moz to future-proof) 389 | */ 390 | 391 | input[type="search"] { 392 | -webkit-appearance: textfield; /* 1 */ 393 | -moz-box-sizing: content-box; 394 | -webkit-box-sizing: content-box; /* 2 */ 395 | box-sizing: content-box; 396 | } 397 | 398 | /* 399 | * Corrects inner padding displayed oddly in S5, Chrome on OSX 400 | */ 401 | 402 | input[type="search"]::-webkit-search-decoration { 403 | -webkit-appearance: none; 404 | } 405 | 406 | /* 407 | * Corrects inner padding and border displayed oddly in FF3/4 408 | * www.sitepen.com/blog/2008/05/14/the-devils-in-the-details-fixing-dojos-toolbar-buttons/ 409 | */ 410 | 411 | button::-moz-focus-inner, 412 | input::-moz-focus-inner { 413 | border: 0; 414 | padding: 0; 415 | } 416 | 417 | /* 418 | * 1. Removes default vertical scrollbar in IE6/7/8/9 419 | * 2. Improves readability and alignment in all browsers 420 | */ 421 | 422 | textarea { 423 | overflow: auto; /* 1 */ 424 | vertical-align: top; /* 2 */ 425 | } 426 | 427 | 428 | /* ============================================================================= 429 | Tables 430 | ========================================================================== */ 431 | 432 | /* 433 | * Remove most spacing between table cells 434 | */ 435 | 436 | table { 437 | border-collapse: collapse; 438 | border-spacing: 0; 439 | } 440 | -------------------------------------------------------------------------------- /msgpack-idl-web/tests/HomeTest.hs: -------------------------------------------------------------------------------- 1 | module HomeTest 2 | ( homeSpecs 3 | ) where 4 | 5 | import Import 6 | import Yesod.Test 7 | 8 | homeSpecs :: Specs 9 | homeSpecs = 10 | describe "These are some example tests" $ 11 | it "loads the index and checks it looks right" $ do 12 | get_ "/" 13 | statusIs 200 14 | htmlAllContain "h1" "Hello" 15 | 16 | post "/" $ do 17 | addNonce 18 | fileByLabel "Choose a file" "tests/main.hs" "text/plain" -- talk about self-reference 19 | byLabel "What's on the file?" "Some Content" 20 | 21 | statusIs 200 22 | htmlCount ".message" 1 23 | htmlAllContain ".message" "Some Content" 24 | htmlAllContain ".message" "text/plain" 25 | -------------------------------------------------------------------------------- /msgpack-idl-web/tests/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE NoMonomorphismRestriction #-} 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Main where 6 | 7 | import Import 8 | import Settings 9 | import Yesod.Logger (defaultDevelopmentLogger) 10 | import Yesod.Default.Config 11 | import Yesod.Test 12 | import Application (makeFoundation) 13 | 14 | import HomeTest 15 | 16 | main :: IO a 17 | main = do 18 | conf <- loadConfig $ (configSettings Testing) { csParseExtra = parseExtra } 19 | logger <- defaultDevelopmentLogger 20 | foundation <- makeFoundation conf logger 21 | app <- toWaiAppPlain foundation 22 | runTests app (connPool foundation) homeSpecs 23 | -------------------------------------------------------------------------------- /msgpack-idl/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2011, Hideyuki Tanaka 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Hideyuki Tanaka nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL.hs: -------------------------------------------------------------------------------- 1 | module Language.MessagePack.IDL ( 2 | module Language.MessagePack.IDL.Syntax, 3 | module Language.MessagePack.IDL.Parser, 4 | module Language.MessagePack.IDL.CodeGen.Haskell, 5 | ) where 6 | 7 | import Language.MessagePack.IDL.Syntax 8 | import Language.MessagePack.IDL.Parser 9 | import Language.MessagePack.IDL.CodeGen.Haskell 10 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/Check.hs: -------------------------------------------------------------------------------- 1 | module Language.MessagePack.IDL.Check ( 2 | check, 3 | ) where 4 | 5 | import Language.MessagePack.IDL.Syntax 6 | 7 | -- TODO: Implement it! 8 | check :: Spec -> Bool 9 | check _ = True 10 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Cpp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Cpp ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.List 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Data.Text.Lazy.IO as LT 13 | import System.FilePath 14 | import Text.Shakespeare.Text 15 | 16 | import Language.MessagePack.IDL.Syntax 17 | 18 | data Config 19 | = Config 20 | { configFilePath :: FilePath 21 | , configNameSpace :: String 22 | , configPFICommon :: Bool 23 | } 24 | deriving (Show, Eq) 25 | 26 | generate:: Config -> Spec -> IO () 27 | generate Config {..} spec = do 28 | let name = takeBaseName configFilePath 29 | once = map toUpper name 30 | ns = LT.splitOn "::" $ LT.pack configNameSpace 31 | 32 | typeHeader 33 | | configPFICommon = 34 | [lt|#include <msgpack.hpp>|] 35 | | otherwise = 36 | [lt|#include <msgpack.hpp>|] 37 | serverHeader 38 | | configPFICommon = 39 | [lt|#include <pficommon/network/mprpc.h> 40 | #include <pficommon/lang/bind.h>|] 41 | | otherwise = 42 | [lt|#include <msgpack/rpc/server.h>|] 43 | clientHeader 44 | | configPFICommon = 45 | [lt|#include <pficommon/network/mprpc.h>|] 46 | | otherwise = 47 | [lt|#include <msgpack/rpc/client.h>|] 48 | 49 | LT.writeFile (name ++ "_types.hpp") $ templ configFilePath ns once "TYPES" [lt| 50 | #include <vector> 51 | #include <map> 52 | #include <string> 53 | #include <stdexcept> 54 | #include <stdint.h> 55 | #{typeHeader} 56 | 57 | #{genNameSpace ns $ LT.concat $ map (genTypeDecl name) spec } 58 | |] 59 | 60 | LT.writeFile (name ++ "_server.hpp") $ templ configFilePath (snoc ns "server") once "SERVER" [lt| 61 | #include "#{name}_types.hpp" 62 | #{serverHeader} 63 | 64 | #{genNameSpace (snoc ns "server") $ LT.concat $ map (genServer configPFICommon) spec} 65 | |] 66 | 67 | LT.writeFile (name ++ "_client.hpp") $ templ configFilePath (snoc ns "client") once "CLIENT" [lt| 68 | #include "#{name}_types.hpp" 69 | #{clientHeader} 70 | 71 | #{genNameSpace (snoc ns "client") $ LT.concat $ map (genClient configPFICommon) spec} 72 | |] 73 | 74 | genTypeDecl :: String -> Decl -> LT.Text 75 | genTypeDecl _ MPMessage {..} = 76 | genMsg msgName msgFields False 77 | 78 | genTypeDecl _ MPException {..} = 79 | genMsg excName excFields True 80 | 81 | genTypeDecl _ MPType { .. } = 82 | [lt| 83 | typedef #{genType tyType} #{tyName}; 84 | |] 85 | 86 | genTypeDecl _ _ = "" 87 | 88 | genMsg name flds isExc = 89 | let fields = map f flds 90 | fs = map (maybe undefined fldName) $ sortField flds 91 | in [lt| 92 | struct #{name}#{e} { 93 | public: 94 | 95 | #{destructor} 96 | MSGPACK_DEFINE(#{T.intercalate ", " fs}); 97 | #{LT.concat fields} 98 | }; 99 | |] 100 | where 101 | e = if isExc then [lt| : public std::exception|] else "" 102 | destructor = if isExc then [lt|~#{name}() throw() {} 103 | |] else "" 104 | 105 | f Field {..} = [lt| 106 | #{genType fldType} #{fldName};|] 107 | 108 | sortField flds = 109 | flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> 110 | find ((==ix). fldId) flds 111 | 112 | genServer :: Bool -> Decl -> LT.Text 113 | genServer False MPService {..} = [lt| 114 | template <class Impl> 115 | class #{serviceName} : public msgpack::rpc::server::base { 116 | public: 117 | 118 | void dispatch(msgpack::rpc::request req) { 119 | try { 120 | std::string method; 121 | req.method().convert(&method); 122 | #{LT.concat $ map genMethodDispatch serviceMethods} 123 | } catch (const msgpack::type_error& e) { 124 | req.error(msgpack::rpc::ARGUMENT_ERROR); 125 | } catch (const std::exception& e) { 126 | req.error(std::string(e.what())); 127 | } 128 | } 129 | }; 130 | |] 131 | where 132 | genMethodDispatch Function {..} = 133 | -- TODO: FIX IT! 134 | let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs in 135 | let params = map g methodArgs in 136 | case params of 137 | [] -> [lt| 138 | if (method == "#{methodName}") { 139 | req.result<#{genRetType methodRetType} >(static_cast<Impl*>(this)->#{methodName}()); 140 | return; 141 | } 142 | |] 143 | _ -> [lt| 144 | if (method == "#{methodName}") { 145 | msgpack::type::tuple<#{LT.intercalate ", " typs} > params; 146 | req.params().convert(¶ms); 147 | req.result<#{genRetType methodRetType} >(static_cast<Impl*>(this)->#{methodName}(#{LT.intercalate ", " params})); 148 | return; 149 | } 150 | |] 151 | where 152 | g fld = [lt|params.get<#{show $ fldId fld}>()|] 153 | 154 | genMethodDispatch _ = "" 155 | 156 | genServer True MPService {..} = [lt| 157 | template <class Impl> 158 | class #{serviceName} : public pfi::network::mprpc::rpc_server { 159 | public: 160 | #{serviceName}(double timeout_sec): rpc_server(timeout_sec) { 161 | #{LT.concat $ map genSetMethod serviceMethods} 162 | } 163 | }; 164 | |] 165 | where 166 | genSetMethod Function {..} = 167 | let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs 168 | sign = [lt|#{genRetType methodRetType}(#{LT.intercalate ", " typs})|] 169 | phs = LT.concat $ [[lt|, pfi::lang::_#{show ix}|] | ix <- [1 .. length (typs)]] 170 | in [lt| 171 | rpc_server::add<#{sign} >("#{methodName}", pfi::lang::bind(&Impl::#{methodName}, static_cast<Impl*>(this)#{phs}));|] 172 | 173 | genSetMethod _ = "" 174 | 175 | genServer _ _ = "" 176 | 177 | genClient :: Bool -> Decl -> LT.Text 178 | genClient False MPService {..} = [lt| 179 | class #{serviceName} { 180 | public: 181 | #{serviceName}(const std::string &host, uint64_t port) 182 | : c_(host, port) {} 183 | #{LT.concat $ map genMethodCall serviceMethods} 184 | private: 185 | msgpack::rpc::client c_; 186 | }; 187 | |] 188 | where 189 | genMethodCall Function {..} = 190 | let args = LT.intercalate ", " $ map arg methodArgs in 191 | let vals = LT.concat $ map val methodArgs in 192 | case methodRetType of 193 | Nothing -> [lt| 194 | void #{methodName}(#{args}) { 195 | c_.call("#{methodName}"#{vals}); 196 | } 197 | |] 198 | Just typ -> [lt| 199 | #{genType typ} #{methodName}(#{args}) { 200 | return c_.call("#{methodName}"#{vals}).get<#{genType typ} >(); 201 | } 202 | |] 203 | where 204 | arg Field {..} = [lt|#{genType fldType} #{fldName}|] 205 | val Field {..} = [lt|, #{fldName}|] 206 | 207 | genMethodCall _ = "" 208 | 209 | genClient True MPService {..} = [lt| 210 | class #{serviceName} : public pfi::network::mprpc::rpc_client { 211 | public: 212 | #{serviceName}(const std::string &host, uint64_t port, double timeout_sec) 213 | : rpc_client(host, port, timeout_sec) {} 214 | #{LT.concat $ map genMethodCall serviceMethods} 215 | private: 216 | }; 217 | |] 218 | where 219 | genMethodCall Function {..} = 220 | let typs = map (genRetType . maybe Nothing (\f -> Just (fldType f))) $ sortField methodArgs 221 | sign = [lt|#{genRetType methodRetType}(#{LT.intercalate ", " typs})|] 222 | args = LT.intercalate ", " $ map arg methodArgs 223 | vals = LT.intercalate ", " $ map val methodArgs in 224 | case methodRetType of 225 | Nothing -> [lt| 226 | void #{methodName}(#{args}) { 227 | call<#{sign}>("#{methodName}")(#{vals}); 228 | } 229 | |] 230 | Just t -> [lt| 231 | #{genType t} #{methodName}(#{args}) { 232 | return call<#{sign}>("#{methodName}")(#{vals}); 233 | } 234 | |] 235 | where 236 | arg Field {..} = [lt|#{genType fldType} #{fldName}|] 237 | val Field {..} = [lt|#{fldName}|] 238 | 239 | genMethodCall _ = "" 240 | 241 | genClient _ _ = "" 242 | 243 | genType :: Type -> LT.Text 244 | genType (TInt sign bits) = 245 | let base = if sign then "int" else "uint" :: LT.Text in 246 | [lt|#{base}#{show bits}_t|] 247 | genType (TFloat False) = 248 | [lt|float|] 249 | genType (TFloat True) = 250 | [lt|double|] 251 | genType TBool = 252 | [lt|bool|] 253 | genType TRaw = 254 | [lt|std::string|] 255 | genType TString = 256 | [lt|std::string|] 257 | genType (TList typ) = 258 | [lt|std::vector<#{genType typ} >|] 259 | genType (TMap typ1 typ2) = 260 | [lt|std::map<#{genType typ1}, #{genType typ2} >|] 261 | genType (TUserDef className params) = 262 | [lt|#{className}|] 263 | genType (TTuple ts) = 264 | -- TODO: FIX 265 | foldr1 (\t1 t2 -> [lt|std::pair<#{t1}, #{t2} >|]) $ map genType ts 266 | genType TObject = 267 | [lt|msgpack::object|] 268 | 269 | genRetType :: Maybe Type -> LT.Text 270 | genRetType Nothing = [lt|void|] 271 | genRetType (Just t) = genType t 272 | 273 | templ :: FilePath -> [LT.Text] -> String -> String -> LT.Text -> LT.Text 274 | templ filepath ns once name content = [lt| 275 | // This file is auto-generated from #{filepath} 276 | // *** DO NOT EDIT *** 277 | 278 | #ifndef #{namespace}_#{once}_#{name}_HPP_ 279 | #define #{namespace}_#{once}_#{name}_HPP_ 280 | 281 | #{content} 282 | 283 | #endif // #{namespace}_#{once}_#{name}_HPP_ 284 | |] where 285 | namespace = LT.intercalate "_" $ map LT.toUpper ns 286 | 287 | 288 | genNameSpace :: [LT.Text] -> LT.Text -> LT.Text 289 | genNameSpace namespace content = f namespace 290 | where 291 | f [] = [lt|#{content}|] 292 | f (n:ns) = [lt| 293 | namespace #{n} { 294 | #{f ns} 295 | } // namespace #{n} 296 | |] 297 | 298 | snoc xs x = xs ++ [x] 299 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Erlang.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Erlang ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.List 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Data.Text.Lazy.IO as LT 13 | import System.FilePath 14 | import Text.Shakespeare.Text 15 | 16 | import Language.MessagePack.IDL.Syntax 17 | 18 | data Config 19 | = Config 20 | { configFilePath :: FilePath 21 | } 22 | deriving (Show, Eq) 23 | 24 | generate:: Config -> Spec -> IO () 25 | generate Config {..} spec = do 26 | let name = takeBaseName configFilePath 27 | once = map toUpper name 28 | 29 | headerFile = name ++ "_types.hrl" 30 | 31 | LT.writeFile (headerFile) $ templ configFilePath once "TYPES" [lt| 32 | -ifndef(#{once}). 33 | -define(#{once}, 1). 34 | 35 | -type mp_string() :: binary(). 36 | 37 | #{LT.concat $ map (genTypeDecl name) spec } 38 | 39 | -endif. 40 | |] 41 | 42 | LT.writeFile (name ++ "_server.tmpl.erl") $ templ configFilePath once "SERVER" [lt| 43 | 44 | -module(#{name}_server). 45 | -author('@msgpack-idl'). 46 | 47 | -include("#{headerFile}"). 48 | 49 | #{LT.concat $ map genServer spec} 50 | |] 51 | 52 | LT.writeFile (name ++ "_client.erl") [lt| 53 | % This file is automatically generated by msgpack-idl. 54 | -module(#{name}_client). 55 | -author('@msgpack-idl'). 56 | 57 | -include("#{headerFile}"). 58 | -export([connect/3, close/1]). 59 | 60 | #{LT.concat $ map genClient spec} 61 | |] 62 | 63 | genTypeDecl :: String -> Decl -> LT.Text 64 | genTypeDecl _ MPMessage {..} = 65 | genMsg msgName msgFields False 66 | 67 | genTypeDecl _ MPException {..} = 68 | genMsg excName excFields True 69 | 70 | genTypeDecl _ MPType { .. } = 71 | [lt| 72 | -type #{tyName}() :: #{genType tyType}. 73 | |] 74 | 75 | genTypeDecl _ _ = "" 76 | 77 | genMsg name flds isExc = 78 | let fields = map f flds 79 | in [lt| 80 | -type #{name}() :: [ 81 | #{LT.intercalate "\n | " fields} 82 | ]. % #{e} 83 | |] 84 | where 85 | e = if isExc then [lt| (exception)|] else "" 86 | f Field {..} = [lt|#{genType fldType} % #{fldName}|] 87 | 88 | sortField flds = 89 | flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> 90 | find ((==ix). fldId) flds 91 | 92 | makeExport i Function {..} = 93 | let j = i + length methodArgs in 94 | [lt|#{methodName}/#{show j}|] 95 | makeExport _ _ = "" 96 | 97 | 98 | genServer :: Decl -> LT.Text 99 | genServer MPService {..} = [lt| 100 | 101 | -export([#{LT.intercalate ", " $ map (makeExport 0) serviceMethods}]). 102 | 103 | #{LT.concat $ map genSetMethod serviceMethods} 104 | 105 | |] 106 | where 107 | genSetMethod Function {..} = 108 | let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs 109 | args = map f methodArgs 110 | f Field {..} = [lt|#{capitalize0 fldName}|] 111 | capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) 112 | 113 | in [lt| 114 | -spec #{methodName}(#{LT.intercalate ", " typs}) -> #{genRetType methodRetType}. 115 | #{methodName}(#{LT.intercalate ", " args}) -> 116 | Reply = <<"ok">>, % write your code here 117 | Reply. 118 | |] 119 | genSetMethod _ = "" 120 | 121 | genServer _ = "" 122 | 123 | genClient :: Decl -> LT.Text 124 | genClient MPService {..} = [lt| 125 | 126 | -export([#{LT.intercalate ", " $ map (makeExport 1) serviceMethods}]). 127 | 128 | -spec connect(inet:ip_address(), inet:port_number(), [proplists:property()]) -> {ok, pid()} | {error, any()}. 129 | connect(Host,Port,Options)-> 130 | msgpack_rpc_client:connect(tcp,Host,Port,Options). 131 | 132 | -spec close(pid())-> ok. 133 | close(Pid)-> 134 | msgpack_rpc_client:close(Pid). 135 | 136 | #{LT.concat $ map genMethodCall serviceMethods} 137 | |] 138 | where 139 | genMethodCall Function {..} = 140 | let typs = map (genRetType . maybe Nothing (Just . fldType)) $ sortField methodArgs 141 | args = map f methodArgs 142 | f Field {..} = [lt|#{capitalize0 fldName}|] 143 | capitalize0 str = T.cons (toUpper $ T.head str) (T.tail str) 144 | in [lt| 145 | -spec #{methodName}(pid(), #{LT.intercalate ", " typs}) -> #{genRetType methodRetType}. 146 | #{methodName}(Pid, #{LT.intercalate ", " args}) -> 147 | msgpack_rpc_client:call(Pid, #{methodName}, [#{LT.intercalate ", " args}]). 148 | |] 149 | where 150 | arg Field {..} = [lt|#{genType fldType} #{fldName}|] 151 | val Field {..} = [lt|#{fldName}|] 152 | 153 | genMethodCall _ = "" 154 | 155 | genClient _ = "" 156 | 157 | genType :: Type -> LT.Text 158 | genType (TInt sign bits) = 159 | let base = if sign then "non_neg_integer" else "integer" :: LT.Text in 160 | [lt|#{base}()|] 161 | genType (TFloat _) = 162 | [lt|float()|] 163 | genType TBool = 164 | [lt|boolean()|] 165 | genType TRaw = 166 | [lt|binary()|] 167 | genType TString = 168 | [lt|mp_string()|] 169 | genType (TList typ) = 170 | [lt|list(#{genType typ})|] 171 | genType (TMap typ1 typ2) = 172 | [lt|list({#{genType typ1}, #{genType typ2}})|] 173 | genType (TUserDef className params) = 174 | [lt|#{className}()|] 175 | genType (TTuple ts) = 176 | -- TODO: FIX 177 | foldr1 (\t1 t2 -> [lt|{#{t1}, #{t2}}|]) $ map genType ts 178 | genType TObject = 179 | [lt|term()|] 180 | 181 | genRetType :: Maybe Type -> LT.Text 182 | genRetType Nothing = [lt|void()|] 183 | genRetType (Just t) = genType t 184 | 185 | templ :: FilePath -> String -> String -> LT.Text -> LT.Text 186 | templ filepath once name content = [lt| 187 | % This file is auto-generated from #{filepath} 188 | 189 | #{content}|] 190 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Haskell.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell, QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Language.MessagePack.IDL.CodeGen.Haskell ( 6 | Config(..), 7 | generate, 8 | ) where 9 | 10 | import Data.Char 11 | import Data.Monoid 12 | import qualified Data.Text as T 13 | import qualified Data.Text.Lazy as LT 14 | import qualified Data.Text.Lazy.IO as LT 15 | import Text.Shakespeare.Text 16 | 17 | import Language.MessagePack.IDL.Syntax as MP 18 | 19 | data Config 20 | = Config 21 | { configFilePath :: FilePath 22 | } 23 | 24 | generate :: Config -> Spec -> IO () 25 | generate Config {..} spec = do 26 | LT.writeFile "Types.hs" [lt| 27 | {-# LANGUAGE TemplateHaskell #-} 28 | 29 | module Types where 30 | 31 | import Data.Int 32 | import Data.MessagePack 33 | import Data.Map (Map) 34 | import qualified Data.Map as Map 35 | import Data.Words 36 | #{LT.concat $ map genTypeDecl spec} 37 | |] 38 | 39 | LT.writeFile "Server.hs" [lt| 40 | |] 41 | 42 | LT.writeFile "Client.hs" [lt| 43 | module Server where 44 | 45 | import Data.ByteString (ByteString) 46 | import qualified Data.ByteString as B 47 | import Data.Map (Map) 48 | import qualified Data.Map as M 49 | import Data.Text (Text) 50 | import qualified Data.Text as T 51 | 52 | import qualified Network.MessagePackRpc.Client as MP 53 | 54 | import Types 55 | #{LT.concat $ map genClient spec} 56 | |] 57 | 58 | genClient :: Decl -> LT.Text 59 | genClient MPService {..} = 60 | [lt| 61 | newtype #{monadName} m a 62 | = #{monadName} { un#{monadName} :: StateT () m a } 63 | deriving (Monad, MonadIO, MonadTrans, MonadState ()) 64 | #{LT.concat $ map genMethod serviceMethods} 65 | |] 66 | where 67 | monadName = classize (serviceName) `mappend` "T" 68 | genMethod Function {..} = 69 | let ts = map (genType . fldType) methodArgs in 70 | let typs = ts ++ [ [lt|#{monadName} (#{genRetType methodRetType})|] ] in 71 | [lt| 72 | #{methodize methodName} :: #{LT.intercalate " -> " typs} 73 | #{methodize methodName} = MP.method "#{methodName}" 74 | |] 75 | genMethod f = error $ "unsupported: " ++ show f 76 | 77 | genClient _ = "" 78 | 79 | genTypeDecl :: Decl -> LT.Text 80 | genTypeDecl MPMessage {..} = 81 | let mems = LT.intercalate "\n , " $ map f msgFields in 82 | [lt| 83 | data #{dataName} 84 | = #{dataName} 85 | { #{mems} 86 | } 87 | deriving (Eq, Show) 88 | deriveObject False ''#{dataName} 89 | |] 90 | where 91 | dataName = classize msgName 92 | f Field {..} = 93 | let fname = uncapital dataName `mappend` (capital $ camelize fldName) in 94 | [lt|#{fname} :: #{genType fldType}|] 95 | 96 | genTypeDecl _ = "" 97 | 98 | genType :: Type -> LT.Text 99 | genType (TInt sign bits) = 100 | let base = if sign then "Int" else "Word" :: T.Text in 101 | [lt|#{base}#{show bits}|] 102 | genType (TFloat False) = 103 | [lt|Float|] 104 | genType (TFloat True) = 105 | [lt|Double|] 106 | genType TBool = 107 | [lt|Bool|] 108 | genType TRaw = 109 | [lt|ByteString|] 110 | genType TString = 111 | [lt|Text|] 112 | genType (TList typ) = 113 | [lt|[#{genType typ}]|] 114 | genType (TMap typ1 typ2) = 115 | [lt|Map (#{genType typ1}) (#{genType typ2})|] 116 | genType (TTuple typs) = 117 | [lt|(#{LT.intercalate ", " $ map genType typs})|] 118 | genType (TUserDef name params) = 119 | [lt|#{classize name}|] 120 | genType (TObject) = 121 | undefined 122 | 123 | genRetType :: Maybe Type -> LT.Text 124 | genRetType Nothing = "()" 125 | genRetType (Just t) = genType t 126 | 127 | classize :: T.Text -> T.Text 128 | classize = capital . camelize 129 | 130 | methodize :: T.Text -> T.Text 131 | methodize = uncapital . camelize 132 | 133 | camelize :: T.Text -> T.Text 134 | camelize = T.concat . map capital . T.words . T.map ubToSpc where 135 | ubToSpc '_' = ' ' 136 | ubToSpc c = c 137 | 138 | capital :: T.Text -> T.Text 139 | capital word = 140 | (T.map toUpper $ T.take 1 word) `mappend` T.drop 1 word 141 | 142 | uncapital :: T.Text -> T.Text 143 | uncapital word = 144 | (T.map toLower $ T.take 1 word) `mappend` T.drop 1 word 145 | 146 | {- 147 | genServer :: Spec -> IO Builder 148 | genServer = undefined 149 | 150 | genClient :: Spec -> IO Builder 151 | genClient spec = do 152 | decs <- runQ $ genClient' spec 153 | putStrLn $ pprint decs 154 | undefined 155 | 156 | genClient' :: Spec -> Q [Dec] 157 | genClient' spec = return . concat =<< mapM genDecl spec 158 | 159 | genDecl :: Decl -> Q [Dec] 160 | genDecl (Message name super fields) = do 161 | let clsName = mkName $ T.unpack name 162 | con = recC clsName $ map genFld fields 163 | d <- dataD (cxt []) clsName [] [con] [''Eq, ''Ord, ''Show] 164 | return [d] 165 | where 166 | genFld (Field fid req typ fname _) = 167 | varStrictType (mkName $ uncapital $ T.unpack name ++ capital (T.unpack fname)) (strictType notStrict $ genType typ) 168 | 169 | genDecl (Service name version meths) = do 170 | return [] 171 | 172 | genDecl _ = do 173 | d <- dataD (cxt []) (mkName "Ign") [] [] [] 174 | return [d] 175 | 176 | genType :: MP.Type -> Q TH.Type 177 | genType (TInt False 8 ) = conT ''Word8 178 | genType (TInt False 16) = conT ''Word16 179 | genType (TInt False 32) = conT ''Word32 180 | genType (TInt False 64) = conT ''Word64 181 | genType (TInt True 8 ) = conT ''Int8 182 | genType (TInt True 16) = conT ''Int16 183 | genType (TInt True 32) = conT ''Int32 184 | genType (TInt True 64) = conT ''Int64 185 | 186 | genType (TFloat False) = conT ''Float 187 | genType (TFloat True ) = conT ''Double 188 | 189 | genType TBool = conT ''Bool 190 | genType TRaw = conT ''B.ByteString 191 | genType TString = conT ''T.Text 192 | 193 | genType (TList typ) = 194 | listT `appT` genType typ 195 | genType (TMap kt vt) = 196 | [t| M.Map $(genType kt) $(genType vt) |] 197 | 198 | genType (TClass name) = 199 | conT $ mkName $ capital $ T.unpack name 200 | 201 | genType (TTuple typs) = 202 | foldl appT (tupleT (length typs)) (map genType typs) 203 | 204 | capital (c:cs) = toUpper c : cs 205 | capital cs = cs 206 | 207 | uncapital (c:cs) = toLower c : cs 208 | uncapital cs = cs 209 | -} 210 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Perl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Perl ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.List 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Data.Text.Lazy.IO as LT 13 | import System.FilePath 14 | import Text.Shakespeare.Text 15 | 16 | import Language.MessagePack.IDL.Syntax 17 | 18 | data Config 19 | = Config 20 | { configFilePath :: FilePath 21 | , configNameSpace :: String 22 | } 23 | deriving (Show, Eq) 24 | 25 | generate:: Config -> Spec -> IO () 26 | generate Config {..} spec = do 27 | let name = takeBaseName configFilePath 28 | once = map toUpper name 29 | ns = LT.splitOn "::" $ LT.pack configNameSpace 30 | 31 | -- types 32 | mapM_ writeType spec 33 | 34 | -- clients 35 | LT.writeFile (name ++ "_client.pm") [lt| 36 | package #{name}_client; 37 | use strict; 38 | use warnings; 39 | use AnyEvent::MPRPC::Client; 40 | #{LT.concat $ map genClient spec} 41 | |] 42 | 43 | writeType :: Decl -> IO () 44 | writeType MPMessage {..} = 45 | let fields = sortBy (\x y -> fldId x `compare` fldId y) msgFields 46 | fieldNames = map fldName fields :: [T.Text] 47 | packageName = msgName :: T.Text 48 | in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName}; 49 | sub new { 50 | return bless { #{LT.concat $ map f fieldNames} }; 51 | } 52 | 53 | 1; 54 | |] 55 | where 56 | f :: T.Text -> LT.Text 57 | f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\"," 58 | 59 | writeType MPException {..} = 60 | let fields = sortBy (\x y -> fldId x `compare` fldId y) excFields 61 | fieldNames = map fldName fields :: [T.Text] 62 | packageName = excName :: T.Text 63 | in LT.writeFile (T.unpack packageName ++ ".pm") [lt|package #{LT.pack $ T.unpack packageName}; 64 | sub new { 65 | return bless { #{LT.concat $ map f fieldNames} }; 66 | } 67 | 68 | 1; 69 | |] 70 | where 71 | f :: T.Text -> LT.Text 72 | f name = LT.append (LT.pack $ T.unpack name) $ LT.pack " => \"\",\n" 73 | 74 | writeType _ = return () 75 | 76 | genClient :: Decl -> LT.Text 77 | genClient MPService {..} = [lt| 78 | sub new { 79 | my ($self, $host, $port) = @_; 80 | my $client = AnyEvent::MPRPC::Client->new( 81 | host => $host, 82 | port => $port 83 | ); 84 | bless { client => $client }, $self; 85 | }; 86 | 87 | sub bar { 88 | my ($self, $lang, $xs) = @_; 89 | $self->{'client'}->call(bar => [$xs, $lang])->recv; 90 | }; 91 | 92 | 1; 93 | |] 94 | 95 | genClient _ = "" 96 | 97 | templ :: FilePath -> String -> String -> LT.Text -> LT.Text 98 | templ filepath once name content = [lt| 99 | // This file is auto-generated from #{filepath} 100 | // *** DO NOT EDIT *** 101 | 102 | #{content} 103 | 104 | |] 105 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Php.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Php ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.List 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Data.Text.Lazy.IO as LT 13 | import System.FilePath 14 | import Text.Shakespeare.Text 15 | import Data.Monoid 16 | 17 | import Language.MessagePack.IDL.Syntax 18 | 19 | data Config 20 | = Config 21 | { configFilePath :: FilePath 22 | } 23 | deriving (Show, Eq) 24 | 25 | generate:: Config -> Spec -> IO () 26 | generate Config {..} spec = do 27 | let name = takeBaseName configFilePath 28 | once = map toUpper name 29 | 30 | LT.writeFile (name ++ "_types.php") $ templ configFilePath once "TYPES" [lt| 31 | include_once 'Net/MessagePackRPC.php'; 32 | 33 | #{LT.concat $ map genTypeDecl spec} 34 | 35 | class ObjectDecoder { 36 | public static $USER_DEFINED_CLASSES = array( 37 | #{LT.concat $ map genClassName spec} 38 | ); 39 | public static function decodeToObject($ret_array, $type_array) { 40 | if ($type_array == "") { 41 | // do nothing 42 | $ret = $ret_array; 43 | } else if (in_array($type_array, self::$USER_DEFINED_CLASSES)) { 44 | // array -> object 45 | $ret = new $type_array(); 46 | $ret_keys = array_keys((array)$ret); 47 | for ($i = 0; $i < count($ret_keys); $i++) { 48 | $ret->{$ret_keys[$i]} = $ret_array[$i]; 49 | } 50 | } else { 51 | // dissolve array 52 | if (is_array($type_array)) { 53 | if (count($type_array) == 1) { 54 | // if array 55 | foreach ($type_array as $key => $type) { 56 | foreach ($ret_array as $ret_key => $ret_value) { 57 | $ret[$ret_key] = $this->decodeToObject($ret_value, $type); 58 | } 59 | } 60 | } else { 61 | // if tuple 62 | $ret = array(); 63 | $i = 0; 64 | foreach ($type_array as $type) { 65 | $ret[$i] = $this->decodeToObject($ret_array[$i], $type); 66 | $i++; 67 | } 68 | } 69 | } else { 70 | // type error 71 | return $ret_array; 72 | } 73 | } 74 | return $ret; 75 | } 76 | } 77 | 78 | |] 79 | 80 | LT.writeFile (name ++ "_client.php") [lt| 81 | <?php 82 | include_once(dirname(__FILE__)."/#{name}_types.php"); 83 | 84 | #{LT.concat $ map genClient spec} 85 | ?> 86 | |] 87 | 88 | genClassName :: Decl -> LT.Text 89 | genClassName MPMessage {..} = 90 | [lt| "#{msgName}", 91 | |] 92 | genClassName _ = "" 93 | 94 | genTypeDecl :: Decl -> LT.Text 95 | genTypeDecl MPMessage {..} = 96 | genMsg msgName msgFields False 97 | 98 | genTypeDecl MPException {..} = 99 | genMsg excName excFields True 100 | 101 | genTypeDecl _ = "" 102 | 103 | genMsg name flds isExc = 104 | let fields = map f flds 105 | fs = map (maybe undefined fldName) $ sortField flds 106 | in [lt| 107 | class #{name}#{e} { 108 | 109 | #{LT.concat fields} 110 | } 111 | |] 112 | where 113 | e = if isExc then [lt| extends Exception|] else "" 114 | 115 | f Field {..} = [lt| public $#{fldName}; 116 | |] 117 | 118 | sortField flds = 119 | flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> 120 | find ((==ix). fldId) flds 121 | 122 | genClient :: Decl -> LT.Text 123 | genClient MPService {..} = [lt| 124 | class #{serviceName} { 125 | public function __construct($host, $port) { 126 | $this->client = new MessagePackRPC_Client($host, $port); 127 | } 128 | #{LT.concat $ map genMethodCall serviceMethods} 129 | private $client; 130 | } 131 | |] 132 | where 133 | genMethodCall Function {..} = 134 | let args = LT.intercalate ", " $ map arg methodArgs in 135 | let sortedArgs = LT.intercalate ", " $ map (maybe undefined arg) $ sortField methodArgs in 136 | case methodRetType of 137 | Nothing -> [lt| 138 | public function #{methodName}(#{args}) { 139 | $this->client->call("#{methodName}", array(#{sortedArgs})); 140 | } 141 | |] 142 | Just typ -> [lt| 143 | public function #{methodName}(#{args}) { 144 | $ret = $this->client->call("#{methodName}", array(#{sortedArgs})); 145 | $type_array = #{genTypeArray typ}; 146 | return ObjectDecoder::decodeToObject($ret, $type_array); 147 | } 148 | |] 149 | where 150 | arg Field {..} = [lt|$#{fldName}|] 151 | 152 | genMethodCall _ = "" 153 | 154 | genClient _ = "" 155 | 156 | genTypeArray :: Type -> LT.Text 157 | genTypeArray (TList typ) = 158 | [lt|array(#{genTypeArray typ})|] 159 | genTypeArray (TMap typ1 typ2) = 160 | [lt|array(#{genTypeArray typ1} => #{genTypeArray typ2})|] 161 | genTypeArray (TUserDef className params) = 162 | [lt|"#{className}"|] 163 | genTypeArray (TTuple ts) = 164 | foldr1 (\t1 t2 -> [lt|array(#{t1}, #{t2})|]) $ map genTypeArray ts 165 | genTypeArray _ = [lt|""|] 166 | 167 | genType :: Type -> LT.Text 168 | genType (TUserDef className params) = 169 | [lt|#{className}|] 170 | genType _ = "" 171 | 172 | templ :: FilePath -> String -> String -> LT.Text -> LT.Text 173 | templ filepath once name content = [lt| 174 | // This file is auto-generated from #{filepath} 175 | // *** DO NOT EDIT *** 176 | <?php 177 | #{content} 178 | ?> 179 | |] 180 | 181 | snoc xs x = xs ++ [x] 182 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Python.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Python ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.List 9 | import Data.Monoid 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Lazy as LT 12 | import qualified Data.Text.Lazy.IO as LT 13 | import System.FilePath 14 | import Text.Shakespeare.Text 15 | import System.Directory 16 | 17 | import Language.MessagePack.IDL.Syntax 18 | 19 | data Config 20 | = Config 21 | { configFilePath :: FilePath } 22 | deriving (Show, Eq) 23 | 24 | generate:: Config -> Spec -> IO () 25 | generate Config {..} spec = do 26 | createDirectoryIfMissing True (takeBaseName configFilePath); 27 | setCurrentDirectory (takeBaseName configFilePath); 28 | LT.writeFile "__init__.py" $ templ configFilePath [lt| 29 | |] 30 | LT.writeFile "types.py" $ templ configFilePath [lt| 31 | import sys 32 | import msgpack 33 | 34 | #{LT.concat $ map (genTypeDecl "") spec } 35 | |] 36 | 37 | LT.writeFile "server.tmpl.py" $ templ configFilePath [lt| 38 | import msgpackrpc 39 | from types import * 40 | # write your server here and change file name to server.py 41 | 42 | |] 43 | 44 | LT.writeFile "client.py" $ templ configFilePath [lt| 45 | import msgpackrpc 46 | from types import * 47 | 48 | #{LT.concat $ map (genClient) spec} 49 | |] 50 | 51 | genTypeDecl :: String -> Decl -> LT.Text 52 | 53 | genTypeDecl _ MPType {..} = [lt| 54 | class #{tyName}: 55 | @staticmethod 56 | def from_msgpack(arg): 57 | return #{fromMsgpack tyType "arg"} 58 | |] 59 | 60 | genTypeDecl _ MPMessage {..} = 61 | genMsg msgName msgFields False 62 | 63 | genTypeDecl _ MPException {..} = 64 | genMsg excName excFields True 65 | 66 | genTypeDecl _ _ = "" 67 | 68 | genMsg :: ToText a => a -> [Field] -> Bool -> LT.Text 69 | genMsg name flds isExc = 70 | let fs = zipWith (\ix -> maybe ("_UNUSED" `mappend` T.pack (show ix)) fldName) [0 .. ] (sortField flds) 71 | in [lt| 72 | class #{name}#{e}: 73 | def __init__(self, #{LT.intercalate ", " $ map g fs}): 74 | #{LT.concat $ map f flds} 75 | def to_msgpack(self): 76 | return (#{LT.concat $ map typ flds} 77 | ) 78 | 79 | @staticmethod 80 | def from_msgpack(arg): 81 | return #{name}( 82 | #{LT.intercalate ",\n " $ map make_arg flds}) 83 | |] 84 | 85 | where 86 | e = if isExc then [lt|(Exception)|] else "" 87 | f Field {..} = [lt| self.#{fldName} = #{fldName} 88 | |] 89 | typ Field {..} = [lt| 90 | self.#{fldName},|] 91 | make_arg Field {..} = 92 | let fldId_str = T.concat $ map T.pack ["arg[", (show fldId), "]"] in 93 | [lt|#{fromMsgpack fldType fldId_str}|] 94 | g str = [lt|#{str}|] 95 | 96 | sortField :: [Field] -> [Maybe Field] 97 | sortField flds = 98 | flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> 99 | find ((==ix). fldId) flds 100 | 101 | genClient :: Decl -> LT.Text 102 | genClient MPService {..} = [lt| 103 | class #{serviceName}: 104 | def __init__ (self, host, port): 105 | address = msgpackrpc.Address(host, port) 106 | self.client = msgpackrpc.Client(address) 107 | #{LT.concat $ map genMethodCall serviceMethods} 108 | |] 109 | where 110 | genMethodCall Function {..} = 111 | let arg_list = zipWith (\ix -> maybe ("_UNUSED" `mappend` T.pack (show ix)) fldName) [0 .. ] $ sortField methodArgs 112 | args = LT.concat $ map (\x -> [lt|, #{x}|]) arg_list 113 | in 114 | case methodRetType of 115 | Nothing -> [lt| 116 | def #{methodName} (self#{args}): 117 | self.client.call('#{methodName}'#{args}) 118 | |] 119 | Just ts -> [lt| 120 | def #{methodName} (self#{args}): 121 | retval = self.client.call('#{methodName}'#{args}) 122 | return #{fromMsgpack ts "retval"} 123 | |] 124 | 125 | genMethodCall _ = "" 126 | 127 | genClient _ = "" 128 | 129 | sanitize :: Char -> Char 130 | sanitize '[' = '_' 131 | sanitize ']' = '_' 132 | sanitize c = c 133 | 134 | fromMsgpack :: Type -> T.Text -> LT.Text 135 | fromMsgpack (TNullable t) name = fromMsgpack t name 136 | fromMsgpack (TInt _ _) name = [lt|#{name}|] 137 | fromMsgpack (TFloat False) name = [lt|#{name}|] 138 | fromMsgpack (TFloat True) name = [lt|#{name}|] 139 | fromMsgpack TBool name = [lt|#{name}|] 140 | fromMsgpack TRaw name = [lt|#{name}|] 141 | fromMsgpack TString name = [lt|#{name}|] 142 | fromMsgpack (TList typ) name = 143 | let 144 | varname = T.append (T.pack "elem_") (T.map sanitize name) in 145 | [lt|[#{fromMsgpack typ varname} for #{varname} in #{name}]|] 146 | 147 | fromMsgpack (TMap typ1 typ2) name = 148 | let 149 | keyname = T.append (T.pack "k_" ) $ T.map sanitize name 150 | valname = T.append (T.pack "v_" ) $ T.map sanitize name 151 | in 152 | [lt|{#{fromMsgpack typ1 keyname} : #{fromMsgpack typ2 valname} for #{keyname},#{valname} in #{name}.items()}|] 153 | 154 | fromMsgpack (TUserDef className _) name = [lt|#{className}.from_msgpack(#{name})|] 155 | 156 | fromMsgpack (TTuple ts) name = 157 | let elems = map (f name) (zip [0..] ts) in 158 | [lt| (#{LT.intercalate ", " elems}) |] 159 | where 160 | f :: T.Text -> (Integer, Type) -> LT.Text 161 | f n (i, (TUserDef className _ )) = [lt|#{className}.from_msgpack(#{n}[#{show i}]) |] 162 | f n (i, _) = [lt|#{n}[#{show i}]|] 163 | 164 | fromMsgpack TObject name = [lt|#{name}|] 165 | 166 | templ :: FilePath -> LT.Text -> LT.Text 167 | templ filepath content = [lt| 168 | # This file is auto-generated from #{filepath} 169 | # *** DO NOT EDIT *** 170 | 171 | #{content} 172 | |] 173 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/CodeGen/Ruby.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes, RecordWildCards, OverloadedStrings #-} 2 | 3 | module Language.MessagePack.IDL.CodeGen.Ruby ( 4 | Config(..), 5 | generate, 6 | ) where 7 | 8 | import Data.Char 9 | import Data.List 10 | import Data.Monoid 11 | import qualified Data.Text as T 12 | import qualified Data.Text.Lazy as LT 13 | import qualified Data.Text.Lazy.IO as LT 14 | import System.FilePath 15 | import Text.Shakespeare.Text 16 | import System.Directory 17 | 18 | import Language.MessagePack.IDL.Syntax 19 | 20 | data Config 21 | = Config 22 | { configFilePath :: FilePath 23 | , configModule :: String 24 | } 25 | deriving (Show, Eq) 26 | 27 | generate:: Config -> Spec -> IO () 28 | generate Config {..} spec = do 29 | createDirectoryIfMissing True (takeBaseName configFilePath); 30 | setCurrentDirectory (takeBaseName configFilePath); 31 | let 32 | mods = LT.splitOn "::" $ LT.pack configModule 33 | 34 | LT.writeFile "types.rb" $ templ configFilePath [lt| 35 | require 'rubygems' 36 | require 'msgpack/rpc' 37 | #{genModule mods $ LT.concat $ map (genTypeDecl "") spec } 38 | |] 39 | 40 | LT.writeFile ("client.rb") $ templ configFilePath [lt| 41 | require 'rubygems' 42 | require 'msgpack/rpc' 43 | require File.join(File.dirname(__FILE__), 'types') 44 | 45 | #{genModule (snoc mods "Client") $ LT.concat $ map genClient spec}|] 46 | 47 | genTypeDecl :: String -> Decl -> LT.Text 48 | genTypeDecl _ MPType {..} = [lt| 49 | class #{capitalizeT tyName} 50 | def #{capitalizeT tyName}.from_tuple(tuple) 51 | #{fromTuple tyType "tuple"} 52 | end 53 | def to_tuple(o) 54 | o 55 | end 56 | end 57 | |] 58 | 59 | genTypeDecl _ MPMessage {..} = 60 | genMsg msgName msgFields False 61 | 62 | genTypeDecl _ MPException {..} = 63 | genMsg excName excFields True 64 | 65 | genTypeDecl _ _ = "" 66 | 67 | genMsg :: T.Text -> [Field] -> Bool -> LT.Text 68 | genMsg name flds isExc = [lt| 69 | class #{capitalizeT name}#{deriveError} 70 | def initialize(#{T.intercalate ", " fs}) 71 | #{LT.intercalate "\n " $ map makeSubst fs} 72 | end 73 | def to_tuple 74 | [#{LT.intercalate ",\n " $ map make_tuple flds}] 75 | end 76 | def to_msgpack(out = '') 77 | to_tuple.to_msgpack(out) 78 | end 79 | def #{capitalizeT name}.from_tuple(tuple) 80 | #{capitalizeT name}.new( 81 | #{LT.intercalate ",\n " $ map make_arg flds} 82 | ) 83 | end 84 | #{indent 2 $ genAccessors sorted_flds} 85 | end 86 | |]-- #{indent 2 $ LT.concat writers} 87 | where 88 | sorted_flds = sortField flds 89 | fs = map (maybe undefined fldName) sorted_flds 90 | -- afs = LT.intercalate ",\n " $ map make_tuple flds 91 | make_tuple Field {..} = 92 | [lt|#{toTuple True fldType fldName}|] 93 | deriveError = if isExc then [lt| < StandardError|] else "" 94 | make_arg Field {..} = 95 | let fldIdstr = T.concat $ map T.pack ["tuple[", (show fldId), "]"] 96 | in [lt|#{fromTuple fldType fldIdstr}|] 97 | 98 | makeSubst :: T.Text -> LT.Text 99 | makeSubst fld = [lt| @#{fld} = #{fld} |] 100 | 101 | toTuple :: Bool -> Type -> T.Text -> LT.Text 102 | toTuple _ (TTuple ts) name = 103 | let elems = map (f name) (zip [0..] ts) in 104 | [lt| [#{LT.concat elems}] |] 105 | where 106 | f :: T.Text -> (Integer, Type) -> LT.Text 107 | f n (i, (TUserDef _fg _ )) = [lt|#{n}[#{show i}].to_tuple}, |] 108 | f n (i, _) = [lt|#{n}[#{show i}], |] 109 | 110 | toTuple True t name = [lt|@#{toTuple False t name}|] 111 | toTuple _ (TNullable t) name = [lt|#{toTuple False t name}|] 112 | toTuple _ (TInt _ _) name = [lt|#{name}|] 113 | toTuple _ (TFloat _) name = [lt|#{name}|] 114 | toTuple _ TBool name = [lt|#{name}|] 115 | toTuple _ TRaw name = [lt|#{name}|] 116 | toTuple _ TString name = [lt|#{name}|] 117 | toTuple _ (TList typ) name = [lt|#{name}.map {|x| #{toTuple False typ "x"}}|] 118 | toTuple _ (TMap typ1 typ2) name = 119 | [lt|#{name}.each_with_object({}) {|(k,v),h| h[#{toTuple False typ1 "k"}] = #{toTuple False typ2 "v"}}|] 120 | toTuple _ (TUserDef _ _) name = [lt|#{name}.to_tuple|] 121 | 122 | toTuple _ _ _ = "" 123 | 124 | fromTuple :: Type -> T.Text -> LT.Text 125 | fromTuple (TNullable t) name = [lt|#{fromTuple t name}|] 126 | fromTuple (TInt _ _) name = [lt|#{name}|] 127 | fromTuple (TFloat _) name = [lt|#{name}|] 128 | fromTuple TBool name = [lt|#{name}|] 129 | fromTuple TRaw name = [lt|#{name}|] 130 | fromTuple TString name = [lt|#{name}|] 131 | fromTuple (TList typ) name = 132 | [lt|#{name}.map { |x| #{fromTuple typ "x"} }|] 133 | 134 | fromTuple (TMap typ1 typ2) name = 135 | [lt|#{name}.each_with_object({}) {|(k,v),h| h[#{fromTuple typ1 "k"}] = #{fromTuple typ2 "v"} }|] 136 | 137 | fromTuple (TUserDef className _) name = [lt|#{capitalizeT className}.from_tuple(#{name})|] 138 | 139 | fromTuple (TTuple ts) name = 140 | let elems = map (f name) (zip [0..] ts) in 141 | [lt| [#{LT.intercalate ", " elems}] |] 142 | where 143 | f :: T.Text -> (Integer, Type) -> LT.Text 144 | f n (i, (TUserDef className _ )) = [lt|#{capitalizeT className}.from_tuple(#{n}[#{show i}]) |] 145 | f n (i, _) = [lt|#{n}[#{show i}] |] 146 | 147 | fromTuple (TObject) name = [lt|#{name}|] 148 | 149 | capitalizeT :: T.Text -> T.Text 150 | capitalizeT a = T.cons (toUpper $ T.head a) (T.tail a) 151 | 152 | sortField :: [Field] -> [Maybe Field] 153 | sortField flds = 154 | flip map [0 .. maximum $ [-1] ++ map fldId flds] $ \ix -> find ((==ix). fldId) flds 155 | 156 | indent :: Int -> LT.Text -> LT.Text 157 | indent ind lines = indentedConcat ind $ LT.lines lines 158 | 159 | indentedConcat :: Int -> [LT.Text] -> LT.Text 160 | indentedConcat ind lines = 161 | LT.dropAround (== '\n') $ LT.unlines $ map (indentLine ind) lines 162 | 163 | indentLine :: Int -> LT.Text -> LT.Text 164 | indentLine _ "" = "" 165 | indentLine ind line = mappend (LT.pack $ replicate ind ' ') line 166 | 167 | {- 168 | extractJust :: [Maybe a] -> [a] 169 | extractJust [] = [] 170 | extractJust (Nothing:xs) = extractJust xs 171 | extractJust (Just v:xs) = v : extractJust xs 172 | -} 173 | 174 | data AccessorType = Read | ReadWrite deriving Eq 175 | 176 | getAccessorType :: Type -> AccessorType 177 | getAccessorType TBool = Read 178 | getAccessorType (TMap _ _) = Read 179 | getAccessorType (TUserDef _ _) = Read 180 | getAccessorType _ = ReadWrite 181 | 182 | genAccessors :: [Maybe Field] -> LT.Text 183 | genAccessors [] = "" 184 | genAccessors fs = [lt| 185 | #{genAccessors' Read "attr_reader" fs}#{genAccessors' ReadWrite "attr_accessor" fs}|] 186 | 187 | genAccessors' :: AccessorType -> String -> [Maybe Field] -> LT.Text 188 | genAccessors' at an flds = gen $ map (maybe undefined fldName) $ filter fldTypeEq flds 189 | where 190 | gen [] = "" 191 | gen fs = [lt| 192 | #{an} #{T.intercalate ", " $ map (mappend ":") fs}|] 193 | 194 | fldTypeEq (Just Field {..}) = at == getAccessorType fldType 195 | fldTypeEq Nothing = False 196 | 197 | 198 | -- TODO: Check when val is not null with TNullable 199 | -- TODO: Write single precision value on TFloat False 200 | {- 201 | genAttrWriter :: Field -> LT.Text 202 | genAttrWriter Field {..} = genAttrWriter' fldType fldName 203 | 204 | genAttrWriter' :: Type -> T.Text -> LT.Text 205 | 206 | genAttrWriter' TBool n = [lt| 207 | def #{n}=(val) 208 | @#{n} = val.to_b 209 | end 210 | |] 211 | 212 | genAttrWriter' (TMap kt vt) n = [lt| 213 | def #{n}=(val) 214 | @#{n} = {} 215 | val.each do |k, v| 216 | #{indent 4 $ convert "k" "newk" kt} 217 | #{indent 4 $ convert "v" "newv" vt} 218 | end 219 | end 220 | |] 221 | where 222 | convert from to (TUserDef t p) = 223 | genConvertingType from to (TUserDef t p) 224 | convert from to _ = [lt|#{to} = #{from}|] 225 | genAttrWriter' (TUserDef name types) n = [lt| 226 | def #{n}=(val) 227 | #{indent 2 $ convert "val" atn (TUserDef name types)} 228 | end 229 | |] 230 | where 231 | atn = [lt|@#{n}|] 232 | convert from to (TUserDef t p) = 233 | genConvertingType from to (TUserDef t p) 234 | genAttrWriter' _ _ = "" 235 | -} 236 | 237 | 238 | genClient :: Decl -> LT.Text 239 | genClient MPService {..} = [lt| 240 | class #{capitalizeT serviceName} 241 | def initialize(host, port) 242 | @cli = MessagePack::RPC::Client.new(host, port) 243 | end#{LT.concat $ map genMethodCall serviceMethods} 244 | end 245 | |] 246 | where 247 | genMethodCall Function {..} = [lt| 248 | def #{methodName}(#{defArgs}) 249 | #{indent 4 $ genConvertingType' callStr "v" methodRetType} 250 | end|] 251 | where 252 | defArgs = T.intercalate ", " $ map fldName methodArgs 253 | callStr = [lt|@cli.call(#{callArgs})|] 254 | callArgs = mappend ":" $ T.intercalate ", " $ methodName : sortedArgNames 255 | sortedArgNames = map (maybe undefined fldName) $ sortField methodArgs 256 | 257 | genClient _ = "" 258 | 259 | genConvertingType :: LT.Text -> LT.Text -> Type -> LT.Text 260 | genConvertingType unpacked _ (TUserDef t _) = [lt| 261 | #{capitalizeT t}.from_tuple(#{unpacked})|] 262 | genConvertingType _ _ _ = "" 263 | 264 | genConvertingType' :: LT.Text -> LT.Text -> Maybe Type -> LT.Text 265 | genConvertingType' unpacked v (Just (TUserDef t p)) = [lt| 266 | #{genConvertingType unpacked v (TUserDef t p)} 267 | |] 268 | genConvertingType' unpacked _ _ = [lt|#{unpacked}|] 269 | 270 | templ :: FilePath -> LT.Text -> LT.Text 271 | templ filepath content = [lt|# This file is auto-generated from #{filepath} 272 | # *** DO NOT EDIT *** 273 | #{content} 274 | |] 275 | 276 | genModule :: [LT.Text] -> LT.Text -> LT.Text 277 | genModule modules content = f modules 278 | where 279 | f [] = [lt|#{content}|] 280 | f (n:ns) = [lt|module #{n} 281 | #{f ns} 282 | end|] 283 | 284 | snoc :: [a] -> a -> [a] 285 | snoc xs x = xs ++ [x] 286 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/Internal.hs: -------------------------------------------------------------------------------- 1 | module Language.MessagePack.IDL.Internal ( 2 | withDirectory 3 | ) where 4 | 5 | import Control.Exception 6 | import System.Directory 7 | 8 | withDirectory :: FilePath -> IO a -> IO a 9 | withDirectory dir m = do 10 | createDirectoryIfMissing True dir 11 | bracket 12 | getCurrentDirectory 13 | setCurrentDirectory 14 | (\_ -> setCurrentDirectory dir >> m) 15 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# Language TemplateHaskell, QuasiQuotes, FlexibleContexts #-} 2 | 3 | module Language.MessagePack.IDL.Parser ( 4 | idl, 5 | ) where 6 | 7 | import Data.Maybe 8 | import qualified Data.Text as T 9 | import Text.Peggy 10 | import Text.Peggy.CodeGen.TH 11 | 12 | import Language.MessagePack.IDL.Syntax 13 | 14 | genDecs $(peggyFile "mpidl.peggy") 15 | -------------------------------------------------------------------------------- /msgpack-idl/Language/MessagePack/IDL/Syntax.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Language.MessagePack.IDL.Syntax where 3 | 4 | import Data.Data 5 | import qualified Data.Text as T 6 | 7 | type Spec = [Decl] 8 | 9 | data Decl 10 | = MPMessage 11 | { msgName :: T.Text 12 | , msgParam :: [T.Text] 13 | , msgFields :: [Field] 14 | } 15 | | MPException 16 | { excName :: T.Text 17 | , excParam :: [T.Text] 18 | , excSuper :: Maybe T.Text 19 | , excFields :: [Field] 20 | } 21 | | MPType 22 | { tyName :: T.Text 23 | , tyType :: Type 24 | } 25 | | MPEnum 26 | { enumName :: T.Text 27 | , enumMem :: [(Int, T.Text)] 28 | } 29 | | MPService 30 | { serviceName :: T.Text 31 | , serviceVersion :: Maybe Int 32 | , serviceMethods :: [Method] 33 | } 34 | deriving (Eq, Show, Data, Typeable) 35 | 36 | data Field 37 | = Field 38 | { fldId :: Int 39 | , fldType :: Type 40 | , fldName :: T.Text 41 | , fldDefault :: Maybe Literal 42 | } 43 | deriving (Eq, Show, Data, Typeable) 44 | 45 | data Method 46 | = Function 47 | { methodInherit :: Bool 48 | , methodName :: T.Text 49 | , methodRetType :: Maybe Type 50 | , methodArgs :: [Field] 51 | } 52 | | InheritName T.Text 53 | | InheritAll 54 | deriving (Eq, Show, Data, Typeable) 55 | 56 | data Type 57 | = TInt Bool Int -- signed? bits 58 | | TFloat Bool -- double prec? 59 | | TBool 60 | | TRaw 61 | | TString 62 | | TNullable Type 63 | | TList Type 64 | | TMap Type Type 65 | | TTuple [Type] 66 | | TUserDef T.Text [Type] 67 | | TObject 68 | deriving (Eq, Show, Data, Typeable) 69 | 70 | data Literal 71 | = LInt Int 72 | | LFloat Double 73 | | LBool Bool 74 | | LNull 75 | | LString T.Text 76 | deriving (Eq, Show, Data, Typeable) 77 | -------------------------------------------------------------------------------- /msgpack-idl/README.md: -------------------------------------------------------------------------------- 1 | IDL compiler for MessagePack RPC 2 | ================================ 3 | 4 | # Install 5 | 6 | ~~~ {.bash} 7 | $ cabal update 8 | $ cabal install msgpack-idl 9 | ~~~ 10 | 11 | If you use ghc <= 7.0.x, you may need to specify template-haskell's version. 12 | 13 | ~~~ {.bash} 14 | $ cabal install msgpack-idl --constraint='template-haskell == 2.5.*' 15 | ~~~ 16 | 17 | # Usage 18 | 19 | ~~~ 20 | msgpack-rpc 0.1 21 | 22 | config [OPTIONS] IDLFILE LANG 23 | MessagePack RPC IDL Compiler 24 | 25 | Common flags: 26 | -o --output=DIR Output directory 27 | -? --help Display help message 28 | -V --version Print version information 29 | ~~~ 30 | 31 | # Tutorial 32 | 33 | * Prepare/Write msgspec file 34 | 35 | ~~~ 36 | message UserInfo { 37 | 1: int uid 38 | 2: string name 39 | 3: int? flags = 1 40 | } 41 | 42 | enum Sites { 43 | 0: SiteA 44 | 1: SiteB 45 | 2: SiteC 46 | } 47 | 48 | message LogInLog { 49 | 1: UserInfo user 50 | 2: Sites site 51 | } 52 | 53 | service Foo { 54 | bool login(1: Sites site, 2: UserInfo) 55 | } 56 | ~~~ 57 | 58 | * execute msgspec command for generating client/server code 59 | 60 | ~~~ {.bash} 61 | $ mprpc foo.msgspec cpp -o cpp 62 | $ ls cpp 63 | client.hpp 64 | server.hpp 65 | types.hpp 66 | ~~~ 67 | -------------------------------------------------------------------------------- /msgpack-idl/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /msgpack-idl/Specification.md: -------------------------------------------------------------------------------- 1 | MessagePack IDL Specification 2 | ============================= 3 | 4 | # Syntax of Specification File 5 | 6 | ~~~ 7 | <spec> <- <message> 8 | / <exception> 9 | / <type-alias> 10 | / <enum> 11 | / <service> 12 | ~~~ 13 | 14 | ## message 15 | 16 | ~~~ 17 | message <name> ['<' <type-param>, ... '>'] { 18 | <field>* 19 | } 20 | ~~~ 21 | 22 | ## exception 23 | 24 | * Similar to message definition. 25 | * It can throw as an exception. 26 | 27 | ~~~ 28 | exception <name> ['<' <type-param>, ... '>'] [< <exception-name>] { 29 | <field>* 30 | } 31 | ~~~ 32 | 33 | ## type alias 34 | 35 | * no type-parameter 36 | 37 | ~~~ 38 | type <name> = <type> 39 | ~~~ 40 | 41 | ## enum 42 | 43 | ~~~ 44 | enum <name> { 45 | <enum-id>: <enum-name> 46 | ... 47 | } 48 | ~~~ 49 | 50 | ## service 51 | 52 | * multiple services can be defind 53 | * One server contains several services 54 | 55 | ~~~ 56 | service <name> [: <version>] { 57 | <method> 58 | ... 59 | } 60 | ~~~ 61 | 62 | ## field 63 | 64 | ~~~ 65 | <field> = <field-id> : <type> <field-name> [ = <literal>] 66 | ~~~ 67 | 68 | ## method 69 | 70 | ~~~ 71 | inherit * # inherit all 72 | inherit <name> # inherit specified method 73 | inherit <type> <name> (<field>, ...) # inherit specified method and check type 74 | <type> <name> (<field>, ...) # define new-method 75 | ~~~ 76 | 77 | # Types 78 | 79 | * Primitive types 80 | - `void` 81 | - `object` 82 | - `bool` 83 | - integral types 84 | - `byte` / `short` / `int` / `long` 85 | - `ubyte` / `ushort` / `uint` / `ulong` 86 | - fractional types 87 | - `float` 88 | - `double` 89 | - `raw` 90 | - `string` 91 | 92 | * Compound types 93 | - `list<type>` 94 | - `map<type, type>` 95 | - `tuple<type, ...>` 96 | - `<type>?` 97 | - nullable type 98 | 99 | * User-defined types 100 | - `<class-name><type, ...>` 101 | 102 | # Literals 103 | 104 | * bool 105 | - `true` 106 | - `false` 107 | 108 | * integral 109 | - `0`, `1`, `-1`, ... 110 | 111 | * fractional 112 | - `3.14`, `.9`, `-1.23`, `1e9`, `2.23e-2` 113 | 114 | * string 115 | - `"Hello, World!"`, `"\n\r\t\u1234"` # unicode string 116 | 117 | * nullable 118 | - `null` 119 | 120 | # include other files 121 | 122 | ~~~ 123 | include "foo.idl" 124 | ~~~ 125 | 126 | # Protocol extensions 127 | 128 | ## Request 129 | 130 | * `(type, msgid, method-name, param)` 131 | - same as normal msgpack-rpc 132 | - calls <method-name> method in newest version of default service 133 | 134 | * `(type, msgid, (method-name, service?, versoin?), param)` 135 | - extension of msgpack-idl 136 | - can specify service name and version 137 | - service name and version can be omitted 138 | - this make one server can serve multiple services 139 | 140 | ## Response 141 | 142 | * `(type, msgid, error, result)` 143 | - same as normal msgpack-rpc 144 | 145 | # Semantics 146 | 147 | * Field 148 | - `field-id` specifies an index of serialized array 149 | - default value specified by `literal` is used when it is omitted 150 | - field type is nullable 151 | - it's value is omitted, it becomes to null. 152 | - otherwise, type error will be occured 153 | 154 | * Version 155 | - server invokes only method matches exact same as specified version. 156 | - `inherit` inherits 157 | - same service 158 | - less version 159 | - has specified method 160 | - largest version's method 161 | -------------------------------------------------------------------------------- /msgpack-idl/exec/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | 4 | import Data.Version 5 | import System.Console.CmdArgs 6 | import Text.Peggy 7 | 8 | import Language.MessagePack.IDL 9 | import Language.MessagePack.IDL.Internal 10 | import qualified Language.MessagePack.IDL.CodeGen.Haskell as Haskell 11 | import qualified Language.MessagePack.IDL.CodeGen.Cpp as Cpp 12 | import qualified Language.MessagePack.IDL.CodeGen.Ruby as Ruby 13 | import qualified Language.MessagePack.IDL.CodeGen.Java as Java 14 | import qualified Language.MessagePack.IDL.CodeGen.Php as Php 15 | import qualified Language.MessagePack.IDL.CodeGen.Python as Python 16 | import qualified Language.MessagePack.IDL.CodeGen.Perl as Perl 17 | import qualified Language.MessagePack.IDL.CodeGen.Erlang as Erlang 18 | 19 | import Paths_msgpack_idl 20 | 21 | data MPIDL 22 | = Haskell 23 | { output_dir :: FilePath 24 | , module_name :: String 25 | , filepath :: FilePath 26 | } 27 | | Cpp 28 | { output_dir :: FilePath 29 | , namespace :: String 30 | , pficommon :: Bool 31 | , filepath :: FilePath } 32 | | Ruby 33 | { output_dir :: FilePath 34 | , modules :: String 35 | , filepath :: FilePath } 36 | | Java 37 | { output_dir :: FilePath 38 | , package :: String 39 | , filepath :: FilePath 40 | } 41 | | Php 42 | { output_dir :: FilePath 43 | , filepath :: FilePath 44 | } 45 | | Python 46 | { output_dir :: FilePath 47 | , filepath :: FilePath 48 | } 49 | | Perl 50 | { output_dir :: FilePath 51 | , namespace :: String 52 | , filepath :: FilePath } 53 | | Erlang 54 | { output_dir :: FilePath 55 | , filepath :: FilePath } 56 | deriving (Show, Eq, Data, Typeable) 57 | 58 | main :: IO () 59 | main = do 60 | conf <- cmdArgs $ 61 | modes [ Haskell 62 | { output_dir = def 63 | , module_name = "" 64 | , filepath = def &= argPos 0 65 | } 66 | , Cpp 67 | { output_dir = def 68 | , namespace = "msgpack" 69 | , pficommon = False 70 | , filepath = def &= argPos 0 71 | } 72 | , Ruby 73 | { output_dir = def 74 | , modules = "MessagePack" 75 | , filepath = def &= argPos 0 76 | } 77 | , Java 78 | { output_dir = def 79 | , package = "msgpack" 80 | , filepath = def &= argPos 0 81 | } 82 | , Php 83 | { output_dir = def 84 | , filepath = def &= argPos 0 85 | } 86 | , Python 87 | { output_dir = def 88 | , filepath = def &= argPos 0 89 | } 90 | , Perl 91 | { output_dir = def 92 | , namespace = "msgpack" 93 | , filepath = def &= argPos 0 94 | } 95 | , Erlang 96 | { output_dir = def 97 | , filepath = def &= argPos 0 98 | } 99 | ] 100 | &= help "MessagePack RPC IDL Compiler" 101 | &= summary ("mpidl " ++ showVersion version) 102 | 103 | compile conf 104 | 105 | compile :: MPIDL -> IO () 106 | compile conf = do 107 | espec <- parseFile idl (filepath conf) 108 | case espec of 109 | Left err -> do 110 | print err 111 | Right spec -> do 112 | print spec 113 | withDirectory (output_dir conf) $ do 114 | case conf of 115 | Cpp {..} -> do 116 | Cpp.generate (Cpp.Config filepath namespace pficommon) spec 117 | 118 | Haskell {..} -> do 119 | Haskell.generate (Haskell.Config filepath) spec 120 | 121 | Java {..} -> do 122 | Java.generate (Java.Config filepath package) spec 123 | 124 | Perl {..} -> do 125 | Perl.generate (Perl.Config filepath namespace) spec 126 | 127 | Php {..} -> do 128 | Php.generate (Php.Config filepath) spec 129 | 130 | Python {..} -> do 131 | Python.generate (Python.Config filepath) spec 132 | 133 | Ruby {..} -> do 134 | Ruby.generate (Ruby.Config filepath modules) spec 135 | 136 | Erlang {..} -> do 137 | Erlang.generate (Erlang.Config filepath) spec 138 | 139 | -------------------------------------------------------------------------------- /msgpack-idl/mpidl.peggy: -------------------------------------------------------------------------------- 1 | idl :: Spec = decl* !. 2 | 3 | decl :: Decl 4 | = "message" identifier typeParam "{" field* "}" 5 | { MPMessage $1 $2 $3 } 6 | / "exception" identifier typeParam ("<" identifier)? "{" field* "}" 7 | { MPException $1 $2 $3 $4 } 8 | / "type" identifier "=" ftype 9 | { MPType $1 $2 } 10 | / "enum" identifier "{" (integer ":" identifier)* "}" 11 | { MPEnum $1 $2 } 12 | / "service" identifier (":" integer)? "{" method* "}" 13 | { MPService $1 $2 $3 } 14 | 15 | typeParam :: [T.Text] 16 | = "<" (identifier, ",") ">" 17 | / "" { [] } 18 | 19 | method :: Method 20 | = "inherit" identifier { InheritName $1 } 21 | / "inherit" "*" { InheritAll } 22 | / "inherit"? rtype identifier "(" (field , ",") ")" 23 | { Function (isJust $1) $3 $2 $4 } 24 | 25 | field :: Field 26 | = integer ":" ftype identifier ("=" literal)? 27 | { Field $1 $2 $3 $4 } 28 | 29 | ftype :: Type 30 | = ftypeNN "?" { TNullable $1 } 31 | / ftypeNN 32 | 33 | rtype :: Maybe Type 34 | = "void" { Nothing } 35 | / ftype { Just $1 } 36 | 37 | ftypeNN :: Type 38 | = "byte" { TInt True 8 } 39 | / "short" { TInt True 16 } 40 | / "int" { TInt True 32 } 41 | / "long" { TInt True 64 } 42 | / "ubyte" { TInt False 8 } 43 | / "ushort" { TInt False 16 } 44 | / "uint" { TInt False 32 } 45 | / "ulong" { TInt False 64 } 46 | / "float" { TFloat False } 47 | / "double" { TFloat True } 48 | / "bool" { TBool } 49 | / "raw" { TRaw } 50 | / "string" { TString } 51 | / "object" { TObject } 52 | 53 | / "list" "<" ftype ">" { TList $1 } 54 | / "map" "<" ftype "," ftype ">" { TMap $1 $2 } 55 | / "tuple" "<" (ftype , ",") ">" { TTuple $1 } 56 | 57 | / identifier ("<" (ftype , ",") ">")? 58 | { TUserDef $1 (fromMaybe [] $2) } 59 | 60 | literal ::: Literal 61 | = integer { LInt $1 } 62 | / "true" { LBool True } 63 | / "false" { LBool False } 64 | / "null" { LNull } 65 | / '\"' charLit* '\"' { LString $ T.pack $1 } 66 | 67 | charLit :: Char 68 | = '\\' escChar 69 | / ![\'\"] . 70 | 71 | escChar :: Char 72 | = 'n' { '\n' } 73 | / 'r' { '\r' } 74 | / 't' { '\t' } 75 | / '\\' { '\\' } 76 | / '\"' { '\"' } 77 | / '\'' { '\'' } 78 | 79 | integer ::: Int 80 | = [0-9]+ { read $1 } 81 | 82 | identifier ::: T.Text 83 | = [a-zA-Z_][a-zA-Z0-9_]* { T.pack ($1 : $2) } 84 | 85 | skip :: () = [ \r\n\t] { () } / comment 86 | comment :: () = '#' _:(!'\n' . { () })* '\n' { () } 87 | delimiter :: () = [()[\]{}<>;:,./?] { () } 88 | -------------------------------------------------------------------------------- /msgpack-idl/msgpack-idl.cabal: -------------------------------------------------------------------------------- 1 | name: msgpack-idl 2 | version: 0.2.1 3 | synopsis: An IDL Compiler for MessagePack 4 | description: An IDL Compiler for MessagePack <http://msgpack.org/> 5 | homepage: http://msgpack.org/ 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Hideyuki Tanaka 9 | maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> 10 | copyright: Copyright (c) 2011, Hideyuki Tanaka 11 | category: Language 12 | stability: Experimental 13 | cabal-version: >=1.8 14 | build-type: Simple 15 | 16 | extra-source-files: mpidl.peggy 17 | 18 | source-repository head 19 | type: git 20 | location: git://github.com/msgpack/msgpack-haskell.git 21 | 22 | library 23 | build-depends: base == 4.* 24 | , bytestring >= 0.9 25 | , text >= 0.11 26 | , shakespeare-text == 1.0.* 27 | , blaze-builder == 0.3.* 28 | , template-haskell >= 2.5 && < 2.9 29 | , containers >= 0.4 30 | , filepath >= 1.1 && < 1.4 31 | , directory 32 | , msgpack == 0.7.* 33 | , peggy == 0.3.* 34 | 35 | ghc-options: -Wall 36 | 37 | exposed-modules: Language.MessagePack.IDL 38 | Language.MessagePack.IDL.Check 39 | Language.MessagePack.IDL.CodeGen.Cpp 40 | Language.MessagePack.IDL.CodeGen.Haskell 41 | Language.MessagePack.IDL.CodeGen.Java 42 | Language.MessagePack.IDL.CodeGen.Perl 43 | Language.MessagePack.IDL.CodeGen.Php 44 | Language.MessagePack.IDL.CodeGen.Python 45 | Language.MessagePack.IDL.CodeGen.Ruby 46 | Language.MessagePack.IDL.CodeGen.Erlang 47 | Language.MessagePack.IDL.Internal 48 | Language.MessagePack.IDL.Parser 49 | Language.MessagePack.IDL.Syntax 50 | 51 | executable mpidl 52 | hs-source-dirs: exec 53 | main-is: main.hs 54 | 55 | build-depends: base == 4.* 56 | , directory >= 1.0 57 | , cmdargs == 0.10.* 58 | , peggy == 0.3.* 59 | , msgpack-idl 60 | 61 | test-suite mpidl-test 62 | type: exitcode-stdio-1.0 63 | hs-source-dirs: test 64 | main-is: test.hs 65 | 66 | build-depends: base == 4.* 67 | , hspec >= 1.1 68 | , msgpack-idl 69 | -------------------------------------------------------------------------------- /msgpack-idl/test/TODO.txt: -------------------------------------------------------------------------------- 1 | 2 | [ ] empty 3 | [ ] message 4 | [ ] exception 5 | [ ] service 6 | 7 | [ ] swap order of 8 | [ ] message 9 | [ ] argument 10 | 11 | [ ] including support 12 | 13 | [ ] versioning 14 | [ ] inherit 15 | 16 | [ ] type-check 17 | [ ] Python 18 | [ ] Ruby 19 | [ ] (Java) 20 | -------------------------------------------------------------------------------- /msgpack-idl/test/idls/empty.idl: -------------------------------------------------------------------------------- 1 | message empty_message { 2 | } 3 | 4 | exception empty_error { 5 | } 6 | 7 | service empty_service { 8 | } 9 | -------------------------------------------------------------------------------- /msgpack-idl/test/test.hs: -------------------------------------------------------------------------------- 1 | import Test.Hspec.Monadic 2 | 3 | main :: IO () 4 | main = hspecX $ do 5 | describe "parser" $ do 6 | it "can parse xxx..." $ do 7 | pending 8 | 9 | describe "checker" $ do 10 | it "can check xxx..." $ do 11 | pending 12 | 13 | describe "generator" $ do 14 | describe "haskell" $ do 15 | it "can generate client" $ do 16 | pending 17 | it "can communicate reference server" $ do 18 | pending 19 | -------------------------------------------------------------------------------- /msgpack-rpc/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2010, Hideyuki Tanaka 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Hideyuki Tanaka nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /msgpack-rpc/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /msgpack-rpc/msgpack-rpc.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: msgpack-rpc 3 | version: 1.0.0 4 | 5 | synopsis: A MessagePack-RPC Implementation 6 | description: A MessagePack-RPC Implementation <http://msgpack.org/> 7 | homepage: http://msgpack.org/ 8 | bug-reports: https://github.com/msgpack/msgpack-haskell/issues 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Hideyuki Tanaka 12 | maintainer: Herbert Valerio Riedel <hvr@gnu.org> 13 | copyright: (c) 2010-2015, Hideyuki Tanaka 14 | category: Network 15 | build-type: Simple 16 | 17 | source-repository head 18 | type: git 19 | location: http://github.com/msgpack/msgpack-haskell.git 20 | subdir: msgpack-rpc 21 | 22 | library 23 | default-language: Haskell2010 24 | hs-source-dirs: src 25 | 26 | exposed-modules: Network.MessagePack.Server 27 | Network.MessagePack.Client 28 | 29 | build-depends: base >= 4.5 && < 4.13 30 | , bytestring >= 0.10.4 && < 0.11 31 | , text >= 1.2.3 && < 1.3 32 | , network >= 2.6 && < 2.9 33 | || >= 3.0 && < 3.1 34 | , mtl >= 2.2.1 && < 2.3 35 | , monad-control >= 1.0.0.0 && < 1.1 36 | , conduit >= 1.2.3.1 && < 1.3 37 | , conduit-extra >= 1.1.3.4 && < 1.3 38 | , binary-conduit >= 1.2.3 && < 1.3 39 | , exceptions >= 0.8 && < 0.11 40 | , binary >= 0.7.1 && < 0.9 41 | , msgpack >= 1.1.0 && < 1.2 42 | 43 | test-suite msgpack-rpc-test 44 | default-language: Haskell2010 45 | type: exitcode-stdio-1.0 46 | hs-source-dirs: test 47 | main-is: test.hs 48 | 49 | build-depends: msgpack-rpc 50 | -- inherited constraints via `msgpack-rpc` 51 | , base 52 | , mtl 53 | , network 54 | -- test-specific dependencies 55 | , async == 2.2.* 56 | , tasty == 1.2.* 57 | , tasty-hunit == 0.10.* 58 | -------------------------------------------------------------------------------- /msgpack-rpc/src/Network/MessagePack/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | ------------------------------------------------------------------- 5 | -- | 6 | -- Module : Network.MessagePackRpc.Client 7 | -- Copyright : (c) Hideyuki Tanaka, 2010-2015 8 | -- License : BSD3 9 | -- 10 | -- Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com> 11 | -- Stability : experimental 12 | -- Portability: portable 13 | -- 14 | -- This module is client library of MessagePack-RPC. 15 | -- The specification of MessagePack-RPC is at 16 | -- <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>. 17 | -- 18 | -- A simple example: 19 | -- 20 | -- > import Network.MessagePack.Client 21 | -- > 22 | -- > add :: Int -> Int -> Client Int 23 | -- > add = call "add" 24 | -- > 25 | -- > main = execClient "localhost" 5000 $ do 26 | -- > ret <- add 123 456 27 | -- > liftIO $ print ret 28 | -- 29 | -------------------------------------------------------------------- 30 | 31 | module Network.MessagePack.Client ( 32 | -- * MessagePack Client type 33 | Client, execClient, 34 | 35 | -- * Call RPC method 36 | call, 37 | 38 | -- * RPC error 39 | RpcError(..), 40 | ) where 41 | 42 | import Control.Applicative 43 | import Control.Exception 44 | import Control.Monad 45 | import Control.Monad.Catch 46 | import Control.Monad.State.Strict as CMS 47 | import Data.Binary as Binary 48 | import qualified Data.ByteString as S 49 | import Data.Conduit 50 | import qualified Data.Conduit.Binary as CB 51 | import Data.Conduit.Network 52 | import Data.Conduit.Serialization.Binary 53 | import Data.MessagePack 54 | import Data.Typeable 55 | import System.IO 56 | 57 | newtype Client a 58 | = ClientT { runClient :: StateT Connection IO a } 59 | deriving (Functor, Applicative, Monad, MonadIO, MonadThrow) 60 | 61 | -- | RPC connection type 62 | data Connection 63 | = Connection 64 | !(ResumableSource IO S.ByteString) 65 | !(Sink S.ByteString IO ()) 66 | !Int 67 | 68 | execClient :: S.ByteString -> Int -> Client a -> IO () 69 | execClient host port m = 70 | runTCPClient (clientSettings port host) $ \ad -> do 71 | (rsrc, _) <- appSource ad $$+ return () 72 | void $ evalStateT (runClient m) (Connection rsrc (appSink ad) 0) 73 | 74 | -- | RPC error type 75 | data RpcError 76 | = ServerError Object -- ^ Server error 77 | | ResultTypeError String -- ^ Result type mismatch 78 | | ProtocolError String -- ^ Protocol error 79 | deriving (Show, Eq, Ord, Typeable) 80 | 81 | instance Exception RpcError 82 | 83 | class RpcType r where 84 | rpcc :: String -> [Object] -> r 85 | 86 | instance MessagePack o => RpcType (Client o) where 87 | rpcc m args = do 88 | res <- rpcCall m (reverse args) 89 | case fromObject res of 90 | Success r -> return r 91 | Error e -> throwM $ ResultTypeError e 92 | 93 | instance (MessagePack o, RpcType r) => RpcType (o -> r) where 94 | rpcc m args arg = rpcc m (toObject arg:args) 95 | 96 | rpcCall :: String -> [Object] -> Client Object 97 | rpcCall methodName args = ClientT $ do 98 | Connection rsrc sink msgid <- CMS.get 99 | (rsrc', res) <- lift $ do 100 | CB.sourceLbs (pack (0 :: Int, msgid, methodName, args)) $$ sink 101 | rsrc $$++ sinkGet Binary.get 102 | CMS.put $ Connection rsrc' sink (msgid + 1) 103 | 104 | case fromObject res of 105 | Error e -> throwM $ ProtocolError e 106 | Success (rtype, rmsgid, rerror, rresult) -> do 107 | 108 | when (rtype /= (1 :: Int)) $ 109 | throwM $ ProtocolError $ 110 | "invalid response type (expect 1, but got " ++ show rtype ++ ")" 111 | 112 | when (rmsgid /= msgid) $ 113 | throwM $ ProtocolError $ 114 | "message id mismatch: expect " 115 | ++ show msgid ++ ", but got " 116 | ++ show rmsgid 117 | 118 | case fromObject rerror of 119 | Error e -> throwM $ ServerError rerror 120 | Success () -> return rresult 121 | 122 | -- | Call an RPC Method 123 | call :: RpcType a 124 | => String -- ^ Method name 125 | -> a 126 | call m = rpcc m [] 127 | -------------------------------------------------------------------------------- /msgpack-rpc/src/Network/MessagePack/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | 9 | ------------------------------------------------------------------- 10 | -- | 11 | -- Module : Network.MessagePackRpc.Server 12 | -- Copyright : (c) Hideyuki Tanaka, 2010-2015 13 | -- License : BSD3 14 | -- 15 | -- Maintainer: tanaka.hideyuki@gmail.com 16 | -- Stability : experimental 17 | -- Portability: portable 18 | -- 19 | -- This module is server library of MessagePack-RPC. 20 | -- The specification of MessagePack-RPC is at 21 | -- <http://redmine.msgpack.org/projects/msgpack/wiki/RPCProtocolSpec>. 22 | -- 23 | -- A simple example: 24 | -- 25 | -- > import Network.MessagePack.Server 26 | -- > 27 | -- > add :: Int -> Int -> Server Int 28 | -- > add x y = return $ x + y 29 | -- > 30 | -- > main = serve 1234 [ method "add" add ] 31 | -- 32 | -------------------------------------------------------------------- 33 | 34 | module Network.MessagePack.Server ( 35 | -- * RPC method types 36 | Method, MethodType(..), 37 | ServerT(..), Server, 38 | -- * Build a method 39 | method, 40 | -- * Start RPC server 41 | serve, 42 | ) where 43 | 44 | import Control.Applicative 45 | import Control.Monad 46 | import Control.Monad.Catch 47 | import Control.Monad.Trans 48 | import Control.Monad.Trans.Control 49 | import Data.Binary 50 | import Data.Conduit 51 | import qualified Data.Conduit.Binary as CB 52 | import Data.Conduit.Network 53 | import Data.Conduit.Serialization.Binary 54 | import Data.List 55 | import Data.MessagePack 56 | import Data.Typeable 57 | 58 | -- ^ MessagePack RPC method 59 | data Method m 60 | = Method 61 | { methodName :: String 62 | , methodBody :: [Object] -> m Object 63 | } 64 | 65 | type Request = (Int, Int, String, [Object]) 66 | type Response = (Int, Int, Object, Object) 67 | 68 | data ServerError = ServerError String 69 | deriving (Show, Typeable) 70 | 71 | instance Exception ServerError 72 | 73 | newtype ServerT m a = ServerT { runServerT :: m a } 74 | deriving (Functor, Applicative, Monad, MonadIO) 75 | 76 | instance MonadTrans ServerT where 77 | lift = ServerT 78 | 79 | type Server = ServerT IO 80 | 81 | class Monad m => MethodType m f where 82 | -- | Create a RPC method from a Hakell function 83 | toBody :: f -> [Object] -> m Object 84 | 85 | instance (Functor m, MonadThrow m, MessagePack o) => MethodType m (ServerT m o) where 86 | toBody m ls = case ls of 87 | [] -> toObject <$> runServerT m 88 | _ -> throwM $ ServerError "argument number error" 89 | 90 | instance (MonadThrow m, MessagePack o, MethodType m r) => MethodType m (o -> r) where 91 | toBody f (x: xs) = 92 | case fromObject x of 93 | Error e -> throwM $ ServerError e 94 | Success r -> toBody (f r) xs 95 | 96 | -- | Build a method 97 | method :: MethodType m f 98 | => String -- ^ Method name 99 | -> f -- ^ Method body 100 | -> Method m 101 | method name body = Method name $ toBody body 102 | 103 | -- | Start RPC server with a set of RPC methods. 104 | serve :: (MonadBaseControl IO m, MonadIO m, MonadCatch m, MonadThrow m) 105 | => Int -- ^ Port number 106 | -> [Method m] -- ^ list of methods 107 | -> m () 108 | serve port methods = runGeneralTCPServer (serverSettings port "*") $ \ad -> do 109 | (rsrc, _) <- appSource ad $$+ return () 110 | (_ :: Either ParseError ()) <- try $ processRequests rsrc (appSink ad) 111 | return () 112 | where 113 | processRequests rsrc sink = do 114 | (rsrc', res) <- rsrc $$++ do 115 | obj <- sinkGet get 116 | case fromObject obj of 117 | Error e -> throwM $ ServerError e 118 | Success req -> lift $ getResponse (req :: Request) 119 | _ <- CB.sourceLbs (pack res) $$ sink 120 | processRequests rsrc' sink 121 | 122 | getResponse (rtype, msgid, methodName, args) = do 123 | when (rtype /= 0) $ 124 | throwM $ ServerError $ "request type is not 0, got " ++ show rtype 125 | ret <- callMethod methodName args 126 | return ((1, msgid, toObject (), ret) :: Response) 127 | 128 | callMethod name args = 129 | case find ((== name) . methodName) methods of 130 | Nothing -> 131 | throwM $ ServerError $ "method '" ++ name ++ "' not found" 132 | Just m -> 133 | methodBody m args 134 | -------------------------------------------------------------------------------- /msgpack-rpc/test/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Control.Concurrent 4 | import Control.Concurrent.Async 5 | import Control.Monad.Trans 6 | import Test.Tasty 7 | import Test.Tasty.HUnit 8 | 9 | import Network.MessagePack.Client 10 | import Network.MessagePack.Server 11 | import Network.Socket (withSocketsDo) 12 | 13 | port :: Int 14 | port = 5000 15 | 16 | main :: IO () 17 | main = withSocketsDo $ defaultMain $ 18 | testGroup "simple service" 19 | [ testCase "test" $ server `race_` (threadDelay 1000 >> client) ] 20 | 21 | server :: IO () 22 | server = 23 | serve port 24 | [ method "add" add 25 | , method "echo" echo 26 | ] 27 | where 28 | add :: Int -> Int -> Server Int 29 | add x y = return $ x + y 30 | 31 | echo :: String -> Server String 32 | echo s = return $ "***" ++ s ++ "***" 33 | 34 | client :: IO () 35 | client = execClient "localhost" port $ do 36 | r1 <- add 123 456 37 | liftIO $ r1 @?= 123 + 456 38 | r2 <- echo "hello" 39 | liftIO $ r2 @?= "***hello***" 40 | where 41 | add :: Int -> Int -> Client Int 42 | add = call "add" 43 | 44 | echo :: String -> Client String 45 | echo = call "echo" 46 | -------------------------------------------------------------------------------- /msgpack/CHANGES.md: -------------------------------------------------------------------------------- 1 | ## 1.0.1.0 2 | 3 | - Fix incorrect MessagePack tag when encoding single-precision `Float`s 4 | - Fix looping/hanging `MessagePack (Maybe a)` instance 5 | - Add support for `binary-0.8` API 6 | - Drop dependency on `blaze-builder` 7 | - Add new operations 8 | - `getWord`, `getWord64`, `getInt64` 9 | - `putWord`, `putWord64`, `putInt64` 10 | - Add `Read` instance for `Object` and `Assoc` 11 | - Add `Generic` instance for `Object` 12 | - Add `Object` instance `ShortByteString` 13 | - Declare API `Trustworthy` for SafeHaskell 14 | -------------------------------------------------------------------------------- /msgpack/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) Hideyuki Tanaka 2009-2010 2 | (c) Herbert Valerio Riedel 2019 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | * Neither the name of the Hideyuki Tanaka nor the 14 | names of its contributors may be used to endorse or promote products 15 | derived from this software without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka AND CONTRIBUTORS ''AS IS'' AND ANY 18 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 19 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 20 | DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY 21 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 22 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 23 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 24 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 25 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 | -------------------------------------------------------------------------------- /msgpack/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /msgpack/msgpack.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: msgpack 3 | version: 1.1.0.0 4 | 5 | synopsis: A Haskell implementation of MessagePack 6 | description: 7 | A Haskell implementation of the <http://msgpack.org/ MessagePack> data interchange format. 8 | MessagePack is a binary format which aims to be compact and supports encoding a superset of the <http://json.org/ JSON> data-model. 9 | . 10 | == Related Packages 11 | . 12 | A JSON adapter for the <https://hackage.haskell.org/package/aeson aeson> library is provided by the <https://hackage.haskell.org/package/msgpack-aeson msgpack-aeson> package. 13 | . 14 | The <http://hackage.haskell.org/package/msgpack-rpc msgpack-rpc> package provides an implementation of the MessagePack-RPC protocol. 15 | 16 | 17 | homepage: http://msgpack.org/ 18 | bug-reports: https://github.com/msgpack/msgpack-haskell/issues 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Hideyuki Tanaka 22 | maintainer: Herbert Valerio Riedel <hvr@gnu.org> 23 | copyright: Copyright (c) Hideyuki Tanaka 2009-2015, 24 | (c) Herbert Valerio Riedel 2019 25 | 26 | category: Data 27 | build-type: Simple 28 | 29 | extra-source-files: 30 | CHANGES.md 31 | test/data/README.md 32 | test/data/10.nil.yaml 33 | test/data/11.bool.yaml 34 | test/data/12.binary.yaml 35 | test/data/20.number-positive.yaml 36 | test/data/21.number-negative.yaml 37 | test/data/22.number-float.yaml 38 | test/data/23.number-bignum.yaml 39 | test/data/30.string-ascii.yaml 40 | test/data/31.string-utf8.yaml 41 | test/data/32.string-emoji.yaml 42 | test/data/40.array.yaml 43 | test/data/41.map.yaml 44 | test/data/42.nested.yaml 45 | test/data/50.timestamp.yaml 46 | test/data/60.ext.yaml 47 | 48 | source-repository head 49 | type: git 50 | location: http://github.com/msgpack/msgpack-haskell.git 51 | subdir: msgpack 52 | 53 | library 54 | default-language: Haskell2010 55 | other-extensions: LambdaCase, OverloadedLists 56 | default-extensions: Trustworthy 57 | hs-source-dirs: src 58 | 59 | exposed-modules: Data.MessagePack 60 | Data.MessagePack.Assoc 61 | Data.MessagePack.Generic 62 | Data.MessagePack.Integer 63 | Data.MessagePack.Timestamp 64 | Data.MessagePack.Object 65 | Data.MessagePack.Get 66 | Data.MessagePack.Put 67 | 68 | other-modules: Data.MessagePack.Tags 69 | Data.MessagePack.Result 70 | Data.MessagePack.Get.Internal 71 | Compat.Binary 72 | Compat.Prelude 73 | 74 | build-depends: base >= 4.7 && < 4.14 75 | , mtl >= 2.2.1 && < 2.3 76 | , bytestring >= 0.10.4 && < 0.11 77 | , text >= 1.2.3 && < 1.3 78 | , containers >= 0.5.5 && < 0.7 79 | , unordered-containers >= 0.2.5 && < 0.3 80 | , hashable >= 1.1.2.4 && < 1.4 81 | , vector >= 0.10.11 && < 0.13 82 | , deepseq >= 1.3 && < 1.5 83 | , binary >= 0.7.1 && < 0.9 84 | , semigroups >= 0.5.0 && < 0.20 85 | , time >= 1.4.2 && < 1.10 86 | , int-cast >= 0.1.1 && < 0.3 87 | , array >= 0.5.0 && < 0.6 88 | 89 | if !impl(ghc > 8.0) 90 | build-depends: fail == 4.9.* 91 | 92 | ghc-options: -Wall 93 | 94 | if impl(ghc >= 7.10) 95 | ghc-options: -fno-warn-trustworthy-safe 96 | 97 | 98 | test-suite msgpack-tests 99 | type: exitcode-stdio-1.0 100 | default-language: Haskell2010 101 | hs-source-dirs: test 102 | 103 | main-is: test.hs 104 | other-modules: Properties 105 | DataCases 106 | 107 | ghc-options: -Wall 108 | 109 | build-depends: msgpack 110 | -- inherited constraints via `msgpack` 111 | , base 112 | , binary 113 | , bytestring 114 | , containers 115 | , text 116 | , time 117 | -- test-specific dependencies 118 | , async == 2.2.* 119 | , filepath == 1.3.* || == 1.4.* 120 | , HsYAML >= 0.1.1 && < 0.2 121 | , tasty == 1.2.* 122 | , tasty-quickcheck == 0.10.* 123 | , tasty-hunit == 0.10.* 124 | , QuickCheck == 2.13.* 125 | -------------------------------------------------------------------------------- /msgpack/src/Compat/Binary.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | -- | Compat layer for "Data.Binary" 4 | -- 5 | -- Supports @binary-0.7.1@ and later 6 | module Compat.Binary 7 | ( Binary(put, get) 8 | 9 | , runPut', Bin.runPut, Bin.PutM, Put 10 | , runGet', runGet, Get 11 | 12 | , Bin.getWord64be, Bin.putWord64be 13 | , Bin.getWord32be, Bin.putWord32be 14 | , Bin.getWord16be, Bin.putWord16be 15 | , Bin.getWord8 , Bin.putWord8 16 | 17 | , getInt64be, putInt64be 18 | , getInt32be, putInt32be 19 | , getInt16be, putInt16be 20 | , getInt8 , putInt8 21 | 22 | , getFloat32be, putFloat32be 23 | , getFloat64be, putFloat64be 24 | 25 | , Bin.getByteString, Bin.putByteString 26 | ) where 27 | 28 | import Compat.Prelude 29 | 30 | import qualified Data.ByteString as BS 31 | import qualified Data.ByteString.Lazy as BL 32 | 33 | import Data.Array.ST (MArray, STUArray, newArray, readArray) 34 | import Data.Array.Unsafe (castSTUArray) 35 | import Data.Binary (Binary (get, put), Get, Put) 36 | import qualified Data.Binary.Get as Bin 37 | import qualified Data.Binary.Put as Bin 38 | import GHC.ST (ST, runST) 39 | 40 | 41 | runGet' :: BS.ByteString -> Get a -> Either String a 42 | runGet' bs0 g = case Bin.pushEndOfInput (Bin.runGetIncremental g `Bin.pushChunk` bs0) of 43 | Bin.Done bs ofs x 44 | | BS.null bs -> Right x 45 | | otherwise -> Left ("unexpected trailing data (ofs="++show ofs++")") 46 | Bin.Partial _ -> Left "truncated data" 47 | Bin.Fail _ ofs e -> Left (e ++ " (ofs=" ++ show ofs ++ ")") 48 | 49 | runPut' :: Put -> BS.ByteString 50 | runPut' = BL.toStrict . Bin.runPut 51 | 52 | runGet :: BL.ByteString -> Get a -> Either String a 53 | runGet bs0 g = case Bin.runGetOrFail g bs0 of 54 | Left (_,ofs,e) -> Left (e ++ " (ofs=" ++ show ofs ++ ")") 55 | Right (bs,ofs,x) 56 | | BL.null bs -> Right x 57 | | otherwise -> Left ("unexpected trailing data (ofs="++show ofs++")") 58 | 59 | -- NB: once we drop support for binary < 0.8.1 we can drop the ops below 60 | 61 | {-# INLINE getInt8 #-} 62 | getInt8 :: Get Int8 63 | getInt8 = intCastIso <$> Bin.getWord8 64 | 65 | {-# INLINE getInt16be #-} 66 | getInt16be :: Get Int16 67 | getInt16be = intCastIso <$> Bin.getWord16be 68 | 69 | {-# INLINE getInt32be #-} 70 | getInt32be :: Get Int32 71 | getInt32be = intCastIso <$> Bin.getWord32be 72 | 73 | {-# INLINE getInt64be #-} 74 | getInt64be :: Get Int64 75 | getInt64be = intCastIso <$> Bin.getWord64be 76 | 77 | {-# INLINE putInt8 #-} 78 | putInt8 :: Int8 -> Put 79 | putInt8 x = Bin.putWord8 (intCastIso x) 80 | 81 | {-# INLINE putInt16be #-} 82 | putInt16be :: Int16 -> Put 83 | putInt16be x = Bin.putWord16be (intCastIso x) 84 | 85 | {-# INLINE putInt32be #-} 86 | putInt32be :: Int32 -> Put 87 | putInt32be x = Bin.putWord32be (intCastIso x) 88 | 89 | {-# INLINE putInt64be #-} 90 | putInt64be :: Int64 -> Put 91 | putInt64be x = Bin.putWord64be (intCastIso x) 92 | 93 | -- NB: Once we drop support for binary < 0.8.4 we can use @binary@'s own {get,put}{Double,Float}be operations 94 | 95 | putFloat32be :: Float -> Put 96 | putFloat32be x = Bin.putWord32be (runST (cast x)) 97 | 98 | putFloat64be :: Double -> Put 99 | putFloat64be x = Bin.putWord64be (runST (cast x)) 100 | 101 | getFloat32be :: Get Float 102 | getFloat32be = do 103 | x <- Bin.getWord32be 104 | return (runST (cast x)) 105 | 106 | getFloat64be :: Get Double 107 | getFloat64be = do 108 | x <- Bin.getWord64be 109 | return (runST (cast x)) 110 | 111 | -- See https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa/7002812#7002812 112 | 113 | {-# INLINE cast #-} 114 | cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b 115 | cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 116 | -------------------------------------------------------------------------------- /msgpack/src/Compat/Prelude.hs: -------------------------------------------------------------------------------- 1 | -- | Common Prelude-ish module 2 | module Compat.Prelude 3 | ( module X 4 | ) where 5 | 6 | import Control.Applicative as X 7 | import Control.DeepSeq as X (NFData (rnf)) 8 | import Control.Monad as X 9 | import Data.Bits as X (complement, shiftL, shiftR, (.&.), 10 | (.|.)) 11 | import Data.Foldable as X (Foldable) 12 | import Data.Int as X 13 | import Data.IntCast as X 14 | import Data.Traversable as X (Traversable) 15 | import Data.Typeable as X (Typeable) 16 | import Data.Word as X 17 | import GHC.Generics as X (Generic) 18 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------- 2 | -- | 3 | -- Module : Data.MessagePack 4 | -- Copyright : © Hideyuki Tanaka 2009-2015 5 | -- , © Herbert Valerio Riedel 2019 6 | -- License : BSD3 7 | -- 8 | -- Simple interface to encode\/decode to\/from the [MessagePack](https://msgpack.org/) format. 9 | -- 10 | -- 11 | -------------------------------------------------------------------- 12 | 13 | module Data.MessagePack ( 14 | -- * Simple interface to pack and unpack msgpack binary 15 | -- ** Lazy 'L.ByteString' 16 | pack, unpack, 17 | 18 | -- ** Strict 'L.ByteString' 19 | pack', unpack', 20 | 21 | -- * Re-export modules 22 | module Data.MessagePack.Assoc, 23 | module Data.MessagePack.Get, 24 | module Data.MessagePack.Object, 25 | module Data.MessagePack.Put, 26 | ) where 27 | 28 | import Compat.Binary (get, runGet, runGet', runPut, runPut') 29 | import qualified Data.ByteString as S 30 | import qualified Data.ByteString.Lazy as L 31 | 32 | import Data.MessagePack.Assoc 33 | import Data.MessagePack.Get 34 | import Data.MessagePack.Object 35 | import Data.MessagePack.Put 36 | 37 | -- | Pack a Haskell value to MessagePack binary. 38 | pack :: MessagePack a => a -> L.ByteString 39 | pack = runPut . toBinary 40 | 41 | -- | Unpack MessagePack binary to a Haskell value. If it fails, it returns 'Left' with an error message. 42 | -- 43 | -- @since 1.1.0.0 44 | unpack :: MessagePack a => L.ByteString -> Either String a 45 | unpack bs = do 46 | obj <- runGet bs get 47 | case fromObject obj of 48 | Success a -> Right a 49 | Error e -> Left e 50 | 51 | 52 | -- | Variant of 'pack' serializing to a strict 'ByteString' 53 | -- 54 | -- @since 1.1.0.0 55 | pack' :: MessagePack a => a -> S.ByteString 56 | pack' = runPut' . toBinary 57 | 58 | -- | Variant of 'unpack' serializing to a strict 'ByteString' 59 | -- 60 | -- @since 1.1.0.0 61 | unpack' :: MessagePack a => S.ByteString -> Either String a 62 | unpack' bs = do 63 | obj <- runGet' bs get 64 | case fromObject obj of 65 | Success a -> Right a 66 | Error e -> Left e 67 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Assoc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | -------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.MessagePack.Assoc 7 | -- Copyright : (c) Daiki Handa, 2010-2011 8 | -- License : BSD3 9 | -- 10 | -- Maintainer: tanaka.hideyuki@gmail.com 11 | -- Stability : experimental 12 | -- Portability: portable 13 | -- 14 | -- MessagePack map labeling type 15 | -- 16 | -------------------------------------------------------------------- 17 | 18 | module Data.MessagePack.Assoc ( 19 | Assoc(..) 20 | ) where 21 | 22 | import Compat.Prelude 23 | 24 | -- not defined for general Functor for performance reason. 25 | -- (ie. you would want to write custom instances for each type using specialized mapM-like functions) 26 | newtype Assoc a 27 | = Assoc { unAssoc :: a } 28 | deriving (Show, Read, Eq, Ord, Typeable, NFData) 29 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Generic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE TypeSynonymInstances #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | module Data.MessagePack.Generic 11 | ( GMessagePack 12 | , genericToObject 13 | , genericFromObject 14 | , GenericMsgPack(..) 15 | ) where 16 | 17 | import Compat.Prelude 18 | 19 | import GHC.Generics 20 | 21 | import Data.MessagePack.Object 22 | 23 | genericToObject :: (Generic a, GMessagePack (Rep a)) => a -> Object 24 | genericToObject = gToObject . from 25 | 26 | genericFromObject :: (Generic a, GMessagePack (Rep a)) => Object -> Result a 27 | genericFromObject x = to <$> gFromObject x 28 | 29 | newtype GenericMsgPack a = GenericMsgPack a 30 | 31 | instance (Generic a, GMessagePack (Rep a)) => MessagePack (GenericMsgPack a) where 32 | toObject (GenericMsgPack a) = genericToObject a 33 | fromObject a = GenericMsgPack <$> genericFromObject a 34 | 35 | class GMessagePack f where 36 | gToObject :: f a -> Object 37 | gFromObject :: Object -> Result (f a) 38 | 39 | instance GMessagePack U1 where 40 | gToObject U1 = ObjectNil 41 | gFromObject ObjectNil = return U1 42 | gFromObject _ = fail "invalid encoding for custom unit type" 43 | 44 | instance (GMessagePack a, GProdPack b) => GMessagePack (a :*: b) where 45 | gToObject = toObject . prodToObject 46 | gFromObject = fromObject >=> prodFromObject 47 | 48 | instance (GSumPack a, GSumPack b, SumSize a, SumSize b) => GMessagePack (a :+: b) where 49 | gToObject = sumToObject 0 size 50 | where 51 | size = unTagged (sumSize :: Tagged (a :+: b) Word64) 52 | 53 | gFromObject = \case 54 | ObjectInt code -> checkSumFromObject0 size (fromIntegral code) 55 | o -> fromObject o >>= uncurry (checkSumFromObject size) 56 | where 57 | size = unTagged (sumSize :: Tagged (a :+: b) Word64) 58 | 59 | instance GMessagePack a => GMessagePack (M1 t c a) where 60 | gToObject (M1 x) = gToObject x 61 | gFromObject x = M1 <$> gFromObject x 62 | 63 | instance MessagePack a => GMessagePack (K1 i a) where 64 | gToObject (K1 x) = toObject x 65 | gFromObject o = K1 <$> fromObject o 66 | 67 | 68 | -- Product type packing. 69 | 70 | class GProdPack f where 71 | prodToObject :: f a -> [Object] 72 | prodFromObject :: [Object] -> Result (f a) 73 | 74 | 75 | instance (GMessagePack a, GProdPack b) => GProdPack (a :*: b) where 76 | prodToObject (a :*: b) = gToObject a : prodToObject b 77 | prodFromObject (a:b) = (:*:) <$> gFromObject a <*> prodFromObject b 78 | prodFromObject _ = fail "invalid encoding for product type" 79 | 80 | instance GMessagePack a => GProdPack (M1 t c a) where 81 | prodToObject (M1 x) = [gToObject x] 82 | prodFromObject [x] = M1 <$> gFromObject x 83 | prodFromObject _ = fail "invalid encoding for product type" 84 | 85 | 86 | -- Sum type packing. 87 | 88 | checkSumFromObject0 :: GSumPack f => Word64 -> Word64 -> Result (f a) 89 | checkSumFromObject0 size code 90 | | code < size = sumFromObject code size ObjectNil 91 | | otherwise = fail "invalid encoding for sum type" 92 | 93 | 94 | checkSumFromObject :: (GSumPack f) => Word64 -> Word64 -> Object -> Result (f a) 95 | checkSumFromObject size code x 96 | | code < size = sumFromObject code size x 97 | | otherwise = fail "invalid encoding for sum type" 98 | 99 | 100 | class GSumPack f where 101 | sumToObject :: Word64 -> Word64 -> f a -> Object 102 | sumFromObject :: Word64 -> Word64 -> Object -> Result (f a) 103 | 104 | 105 | instance (GSumPack a, GSumPack b) => GSumPack (a :+: b) where 106 | sumToObject code size = \case 107 | L1 x -> sumToObject code sizeL x 108 | R1 x -> sumToObject (code + sizeL) sizeR x 109 | where 110 | sizeL = size `shiftR` 1 111 | sizeR = size - sizeL 112 | 113 | sumFromObject code size x 114 | | code < sizeL = L1 <$> sumFromObject code sizeL x 115 | | otherwise = R1 <$> sumFromObject (code - sizeL) sizeR x 116 | where 117 | sizeL = size `shiftR` 1 118 | sizeR = size - sizeL 119 | 120 | 121 | instance {-# OVERLAPPING #-} GSumPack (C1 c U1) where 122 | sumToObject code _ _ = toObject code 123 | sumFromObject _ _ = gFromObject 124 | 125 | 126 | instance {-# OVERLAPPABLE #-} GMessagePack a => GSumPack (C1 c a) where 127 | sumToObject code _ x = toObject (code, gToObject x) 128 | sumFromObject _ _ = gFromObject 129 | 130 | 131 | -- Sum size. 132 | 133 | class SumSize f where 134 | sumSize :: Tagged f Word64 135 | 136 | newtype Tagged (s :: * -> *) b = Tagged { unTagged :: b } 137 | 138 | instance (SumSize a, SumSize b) => SumSize (a :+: b) where 139 | sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + 140 | unTagged (sumSize :: Tagged b Word64) 141 | 142 | instance SumSize (C1 c a) where 143 | sumSize = Tagged 1 144 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Get.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | -------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.MessagePack.Get 7 | -- Copyright : © Hideyuki Tanaka 2009-2015 8 | -- , © Herbert Valerio Riedel 2019 9 | -- License : BSD3 10 | -- 11 | -- MessagePack Deserializer using "Data.Binary" 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | module Data.MessagePack.Get 16 | ( getNil 17 | , getBool 18 | 19 | , getFloat 20 | , getDouble 21 | 22 | , getInt 23 | , getWord 24 | , getInt64 25 | , getWord64 26 | 27 | , getStr 28 | , getBin 29 | 30 | , getArray 31 | , getMap 32 | 33 | , getExt 34 | , getExt' 35 | ) where 36 | 37 | import Compat.Binary 38 | import Compat.Prelude 39 | import Data.MessagePack.Get.Internal 40 | import Data.MessagePack.Integer 41 | 42 | -- | Deserialize an integer into an 'Int' 43 | -- 44 | -- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int' type. 45 | -- 46 | -- @since 1.1.0.0 47 | getInt :: Get Int 48 | getInt = maybe empty pure =<< fromMPInteger <$> get 49 | 50 | -- | Deserialize an integer into a 'Word' 51 | -- 52 | -- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word' type. 53 | -- 54 | -- @since 1.0.1.0 55 | getWord :: Get Word 56 | getWord = maybe empty pure =<< fromMPInteger <$> get 57 | 58 | -- | Deserialize an integer into an 'Int64' 59 | -- 60 | -- This operation will fail if the encoded integer doesn't fit into the value range of the 'Int64' type. 61 | -- 62 | -- @since 1.0.1.0 63 | getInt64 :: Get Int64 64 | getInt64 = maybe empty pure =<< fromMPInteger <$> get 65 | 66 | -- | Deserialize an integer into a 'Word' 67 | -- 68 | -- This operation will fail if the encoded integer doesn't fit into the value range of the 'Word64' type. 69 | -- 70 | -- @since 1.0.1.0 71 | getWord64 :: Get Word64 72 | getWord64 = maybe empty pure =<< fromMPInteger <$> get 73 | 74 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Get/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | 4 | -------------------------------------------------------------------- 5 | -- | 6 | -- Module : Data.MessagePack.Get 7 | -- Copyright : © Hideyuki Tanaka 2009-2015 8 | -- , © Herbert Valerio Riedel 2019 9 | -- License : BSD3 10 | -- 11 | -- MessagePack Deserializer using "Data.Binary" 12 | -- 13 | -------------------------------------------------------------------- 14 | 15 | module Data.MessagePack.Get.Internal 16 | ( getNil, tryNil 17 | , getBool, tryBool 18 | 19 | , getFloat, tryFloat 20 | , getDouble, tryDouble 21 | 22 | , getStr, tryStr 23 | , getBin, tryBin 24 | 25 | , getArray, tryArray 26 | , getMap, tryMap 27 | 28 | , getExt, tryExt 29 | , getExt', tryExt' 30 | ) where 31 | 32 | import Compat.Prelude 33 | 34 | import qualified Data.ByteString as S 35 | import qualified Data.Text as T 36 | import qualified Data.Text.Encoding as T 37 | import qualified Data.Vector as V 38 | 39 | import Compat.Binary 40 | import Data.MessagePack.Tags 41 | 42 | mkGet :: (Word8 -> t -> Get a -> Get b) -> t -> String -> Get b 43 | mkGet tryT f n = do { tag <- getWord8; tryT tag f empty } <|> fail n 44 | 45 | getNil :: Get () 46 | getNil = mkGet tryNil id "expected MessagePack nil" 47 | 48 | getBool :: Get Bool 49 | getBool = mkGet tryBool id "expected MessagePack bool" 50 | 51 | getFloat :: Get Float 52 | getFloat = mkGet tryFloat id "expected MessagePack float32" 53 | 54 | getDouble :: Get Double 55 | getDouble = mkGet tryDouble id "expected MessagePack float64" 56 | 57 | getStr :: Get T.Text 58 | getStr = mkGet tryStr id "expected MessagePack str" 59 | 60 | getBin :: Get S.ByteString 61 | getBin = mkGet tryBin id "expected MessagePack bin" 62 | 63 | getArray :: Get a -> Get (V.Vector a) 64 | getArray g = mkGet (tryArray g) id "expected MessagePack array" 65 | 66 | getMap :: Get a -> Get b -> Get (V.Vector (a, b)) 67 | getMap k v = mkGet (tryMap k v) id "Map" 68 | 69 | getExt :: Get (Int8, S.ByteString) 70 | getExt = mkGet tryExt id "expected MessagePack ext" 71 | 72 | -- | @since 1.1.0.0 73 | getExt' :: (Int8 -> Word32 -> Get a) -> Get a 74 | getExt' getdat = mkGet (tryExt' getdat) id "expected MessagePack ext" 75 | 76 | ---------------------------------------------------------------------------- 77 | -- primitives that take a tag as first argument 78 | 79 | {-# INLINE tryNil #-} 80 | tryNil :: Word8 -> (() -> a) -> Get a -> Get a 81 | tryNil tag f cont = case tag of 82 | TAG_nil -> pure $! f () 83 | _ -> cont 84 | 85 | {-# INLINE tryBool #-} 86 | tryBool :: Word8 -> (Bool -> a) -> Get a -> Get a 87 | tryBool tag f cont = case tag of 88 | TAG_false -> pure $! f False 89 | TAG_true -> pure $! f True 90 | _ -> cont 91 | 92 | {-# INLINE tryFloat #-} 93 | tryFloat :: Word8 -> (Float -> a) -> Get a -> Get a 94 | tryFloat tag f cont = case tag of 95 | TAG_float32 -> f <$> getFloat32be 96 | _ -> cont 97 | 98 | {-# INLINE tryDouble #-} 99 | tryDouble :: Word8 -> (Double -> a) -> Get a -> Get a 100 | tryDouble tag f cont = case tag of 101 | TAG_float64 -> f <$> getFloat64be 102 | _ -> cont 103 | 104 | {-# INLINE tryStr #-} 105 | tryStr :: Word8 -> (T.Text -> a) -> Get a -> Get a 106 | tryStr tag f cont = case tag of 107 | t | Just sz <- is_TAG_fixstr t -> cont' sz 108 | TAG_str8 -> cont' . intCast =<< getWord8 109 | TAG_str16 -> cont' . intCast =<< getWord16be 110 | TAG_str32 -> cont' =<< getWord32be 111 | _ -> cont 112 | where 113 | cont' len = do 114 | len' <- fromSizeM "getStr: data exceeds capacity of ByteString/Text" len 115 | bs <- getByteString len' 116 | case T.decodeUtf8' bs of 117 | Left _ -> fail "getStr: invalid UTF-8 encoding" 118 | Right v -> pure $! f v 119 | 120 | {-# INLINE tryBin #-} 121 | tryBin :: Word8 -> (S.ByteString -> a) -> Get a -> Get a 122 | tryBin tag f cont = case tag of 123 | TAG_bin8 -> cont' . intCast =<< getWord8 124 | TAG_bin16 -> cont' . intCast =<< getWord16be 125 | TAG_bin32 -> cont' =<< getWord32be 126 | _ -> cont 127 | where 128 | cont' len = do 129 | len' <- fromSizeM "getBin: data exceeds capacity of ByteString" len 130 | f <$> getByteString len' 131 | 132 | {-# INLINE tryArray #-} 133 | tryArray :: Get b -> Word8 -> (V.Vector b -> a) -> Get a -> Get a 134 | tryArray g tag f cont = case tag of 135 | t | Just sz <- is_TAG_fixarray t -> cont' sz 136 | TAG_array16 -> cont' . intCast =<< getWord16be 137 | TAG_array32 -> cont' =<< getWord32be 138 | _ -> cont 139 | where 140 | cont' len = do 141 | len' <- fromSizeM "getArray: data exceeds capacity of Vector" len 142 | f <$> V.replicateM len' g 143 | 144 | {-# INLINE tryMap #-} 145 | tryMap :: Get k -> Get v -> Word8 -> (V.Vector (k,v) -> a) -> Get a -> Get a 146 | tryMap k v tag f cont = case tag of 147 | t | Just sz <- is_TAG_fixmap t -> cont' sz 148 | TAG_map16 -> cont' . intCast =<< getWord16be 149 | TAG_map32 -> cont' =<< getWord32be 150 | _ -> cont 151 | where 152 | cont' len = do 153 | len' <- fromSizeM "getMap: data exceeds capacity of Vector" len 154 | f <$> V.replicateM len' ((,) <$> k <*> v) 155 | 156 | {-# INLINE tryExt #-} 157 | tryExt :: Word8 -> ((Int8,S.ByteString) -> a) -> Get a -> Get a 158 | tryExt tag f cont = tryExt' go tag f cont 159 | where 160 | go :: Int8 -> Word32 -> Get (Int8,S.ByteString) 161 | go typ len = do 162 | len' <- fromSizeM "getExt: data exceeds capacity of ByteString" len 163 | (,) typ <$> getByteString len' 164 | 165 | 166 | {-# INLINE tryExt' #-} 167 | tryExt' :: (Int8 -> Word32 -> Get b) -> Word8 -> (b -> a) -> Get a -> Get a 168 | tryExt' g tag f cont = case tag of 169 | TAG_fixext1 -> cont' 1 170 | TAG_fixext2 -> cont' 2 171 | TAG_fixext4 -> cont' 4 172 | TAG_fixext8 -> cont' 8 173 | TAG_fixext16 -> cont' 16 174 | TAG_ext8 -> cont' . intCast =<< getWord8 175 | TAG_ext16 -> cont' . intCast =<< getWord16be 176 | TAG_ext32 -> cont' =<< getWord32be 177 | _ -> cont 178 | 179 | where 180 | cont' len = do 181 | typ <- getInt8 182 | f <$> g typ len 183 | 184 | 185 | fromSizeM :: String -> Word32 -> Get Int 186 | fromSizeM label sz = maybe (fail label) pure (intCastMaybe sz) 187 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Put.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | -------------------------------------------------------------------- 4 | -- | 5 | -- Module : Data.MessagePack.Put 6 | -- Copyright : © Hideyuki Tanaka 2009-2015 7 | -- , © Herbert Valerio Riedel 2019 8 | -- License : BSD3 9 | -- 10 | -- MessagePack Serializer using "Data.Binary". 11 | -- 12 | -------------------------------------------------------------------- 13 | 14 | module Data.MessagePack.Put ( 15 | putNil, putBool, putFloat, putDouble, 16 | putInt, putWord, putInt64, putWord64, 17 | putStr, putBin, putArray, putArray', putMap, putExt, putExt' 18 | ) where 19 | 20 | import Compat.Prelude 21 | import Prelude hiding (putStr) 22 | 23 | import qualified Data.ByteString as S 24 | import qualified Data.Text as T 25 | import qualified Data.Text.Encoding as T 26 | import qualified Data.Vector as V 27 | 28 | import Compat.Binary 29 | import Data.MessagePack.Integer 30 | import Data.MessagePack.Tags 31 | 32 | putNil :: Put 33 | putNil = putWord8 TAG_nil 34 | 35 | putBool :: Bool -> Put 36 | putBool False = putWord8 TAG_false 37 | putBool True = putWord8 TAG_true 38 | 39 | -- | Encodes an 'Int' to MessagePack 40 | -- 41 | -- See also 'MPInteger' and its 'Binary' instance. 42 | putInt :: Int -> Put 43 | putInt = put . toMPInteger 44 | 45 | -- | @since 1.0.1.0 46 | putWord :: Word -> Put 47 | putWord = put . toMPInteger 48 | 49 | -- | @since 1.0.1.0 50 | putInt64 :: Int64 -> Put 51 | putInt64 = put . toMPInteger 52 | 53 | -- | @since 1.0.1.0 54 | putWord64 :: Word64 -> Put 55 | putWord64 = put . toMPInteger 56 | 57 | putFloat :: Float -> Put 58 | putFloat f = putWord8 TAG_float32 >> putFloat32be f 59 | 60 | putDouble :: Double -> Put 61 | putDouble d = putWord8 TAG_float64 >> putFloat64be d 62 | 63 | putStr :: T.Text -> Put 64 | putStr t = do 65 | let bs = T.encodeUtf8 t 66 | toSizeM ("putStr: data exceeds 2^32-1 byte limit of MessagePack") (S.length bs) >>= \case 67 | len | len < 32 -> putWord8 (TAG_fixstr .|. fromIntegral len) 68 | | len < 0x100 -> putWord8 TAG_str8 >> putWord8 (fromIntegral len) 69 | | len < 0x10000 -> putWord8 TAG_str16 >> putWord16be (fromIntegral len) 70 | | otherwise -> putWord8 TAG_str32 >> putWord32be (fromIntegral len) 71 | putByteString bs 72 | 73 | putBin :: S.ByteString -> Put 74 | putBin bs = do 75 | toSizeM ("putBin: data exceeds 2^32-1 byte limit of MessagePack") (S.length bs) >>= \case 76 | len | len < 0x100 -> putWord8 TAG_bin8 >> putWord8 (fromIntegral len) 77 | | len < 0x10000 -> putWord8 TAG_bin16 >> putWord16be (fromIntegral len) 78 | | otherwise -> putWord8 TAG_bin32 >> putWord32be (fromIntegral len) 79 | putByteString bs 80 | 81 | putArray :: (a -> Put) -> V.Vector a -> Put 82 | putArray p xs = do 83 | len <- toSizeM ("putArray: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) 84 | putArray' len (V.mapM_ p xs) 85 | 86 | -- | @since 1.1.0.0 87 | putArray' :: Word32 -- ^ number of array elements 88 | -> Put -- ^ 'Put' action emitting array elements (__NOTE__: it's the responsibility of the caller to ensure that the declared array length matches exactly the data generated by the 'Put' action) 89 | -> Put 90 | putArray' len putter = do 91 | case () of 92 | _ | len < 16 -> putWord8 (TAG_fixarray .|. fromIntegral len) 93 | | len < 0x10000 -> putWord8 TAG_array16 >> putWord16be (fromIntegral len) 94 | | otherwise -> putWord8 TAG_array32 >> putWord32be (fromIntegral len) 95 | putter 96 | 97 | putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put 98 | putMap p q xs = do 99 | toSizeM ("putMap: data exceeds 2^32-1 element limit of MessagePack") (V.length xs) >>= \case 100 | len | len < 16 -> putWord8 (TAG_fixmap .|. fromIntegral len) 101 | | len < 0x10000 -> putWord8 TAG_map16 >> putWord16be (fromIntegral len) 102 | | otherwise -> putWord8 TAG_map32 >> putWord32be (fromIntegral len) 103 | V.mapM_ (\(a, b) -> p a >> q b) xs 104 | 105 | -- | __NOTE__: MessagePack is limited to maximum extended data payload size of \( 2^{32}-1 \) bytes. 106 | putExt :: Int8 -> S.ByteString -> Put 107 | putExt typ dat = do 108 | sz <- toSizeM "putExt: data exceeds 2^32-1 byte limit of MessagePack" (S.length dat) 109 | putExt' typ (sz, putByteString dat) 110 | 111 | -- | @since 1.1.0.0 112 | putExt' :: Int8 -- ^ type-id of extension data (__NOTE__: The values @[ -128 .. -2 ]@ are reserved for future use by the MessagePack specification). 113 | -> (Word32,Put) -- ^ @(size-of-data, data-'Put'-action)@ (__NOTE__: it's the responsibility of the caller to ensure that the declared size matches exactly the data generated by the 'Put' action) 114 | -> Put 115 | putExt' typ (sz,putdat) = do 116 | case sz of 117 | 1 -> putWord8 TAG_fixext1 118 | 2 -> putWord8 TAG_fixext2 119 | 4 -> putWord8 TAG_fixext4 120 | 8 -> putWord8 TAG_fixext8 121 | 16 -> putWord8 TAG_fixext16 122 | len | len < 0x100 -> putWord8 TAG_ext8 >> putWord8 (fromIntegral len) 123 | | len < 0x10000 -> putWord8 TAG_ext16 >> putWord16be (fromIntegral len) 124 | | otherwise -> putWord8 TAG_ext32 >> putWord32be (fromIntegral len) 125 | putInt8 typ 126 | putdat 127 | 128 | ---------------------------------------------------------------------------- 129 | 130 | toSizeM :: String -> Int -> PutM Word32 131 | toSizeM label len0 = maybe (error label) pure (intCastMaybe len0) 132 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Result.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveFoldable #-} 4 | {-# LANGUAGE DeriveFunctor #-} 5 | {-# LANGUAGE DeriveGeneric #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | 8 | -- | 9 | -- Module : Data.MessagePack.Integer 10 | -- Copyright : © Herbert Valerio Riedel 2019 11 | -- License : BSD3 12 | -- 13 | -- Type representing MessagePack integers 14 | -- 15 | -- @since 1.1.0.0 16 | module Data.MessagePack.Result 17 | ( Result(..) 18 | ) where 19 | 20 | import Compat.Prelude 21 | import qualified Control.Monad.Fail as Fail 22 | 23 | -- | The result of decoding from MessagePack 24 | -- 25 | -- @since 1.1.0.0 26 | data Result a = Error String 27 | | Success a 28 | deriving (Eq, Show, Functor, Typeable, Generic, Foldable, Traversable) 29 | 30 | instance NFData a => NFData (Result a) where 31 | rnf (Error e) = rnf e 32 | rnf (Success a) = rnf a 33 | 34 | instance Applicative Result where 35 | pure = Success 36 | (<*>) = ap 37 | 38 | instance Monad Result where 39 | Success a >>= m = m a 40 | Error err >>= _ = Error err 41 | 42 | #if !MIN_VERSION_base(4,13,0) 43 | return = pure 44 | fail = Fail.fail 45 | #endif 46 | 47 | instance Fail.MonadFail Result where 48 | fail = Error 49 | 50 | instance Alternative Result where 51 | empty = fail "Alternative(empty)" 52 | a@(Success _) <|> _ = a 53 | _ <|> b = b 54 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Tags.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE PatternSynonyms #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | #if __GLASGOW_HASKELL__ >= 800 6 | {-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} 7 | #endif 8 | 9 | -- | 10 | -- Module : Data.MessagePack.Tags 11 | -- Copyright : © Herbert Valerio Riedel 2019 12 | -- License : BSD3 13 | -- 14 | -- The tag constants in this module were carefully copied from the table at 15 | -- 16 | -- https://github.com/msgpack/msgpack/blob/master/spec.md#formats 17 | -- 18 | module Data.MessagePack.Tags where 19 | 20 | import Compat.Prelude 21 | 22 | -- | Test whether tag is a fixint 23 | is_TAG_fixint :: Word8 -> Bool 24 | is_TAG_fixint tag = (tag .&. TAG_MASK_fixintp == TAG_fixintp) 25 | || (tag .&. TAG_MASK_fixintn == TAG_fixintn) 26 | {-# INLINE is_TAG_fixint #-} 27 | 28 | pattern TAG_fixintn = 0xe0 -- 0b111xxxxx [0xe0 .. 0xff] / [-32 .. -1] 29 | pattern TAG_MASK_fixintn = 0xe0 -- 0b11100000 30 | 31 | pattern TAG_fixintp = 0x00 -- 0b0xxxxxxx [0x00 .. 0x7f] / [0 .. 127] 32 | pattern TAG_MASK_fixintp = 0x80 -- 0b10000000 33 | 34 | -- | Test whether tag is a fixmap and return embedded-size if it is 35 | is_TAG_fixmap :: Word8 -> Maybe Word32 36 | is_TAG_fixmap t 37 | | t .&. TAG_MASK_fixmap == TAG_fixmap = Just $! intCast (t .&. complement TAG_MASK_fixmap) 38 | | otherwise = Nothing 39 | {-# INLINE is_TAG_fixmap #-} 40 | 41 | pattern TAG_fixmap = 0x80 -- 0b1000xxxx [0x80 .. 0x8f] 42 | pattern TAG_MASK_fixmap = 0xf0 -- 0b11110000 43 | 44 | -- | Test whether tag is a fixarray and return embedded-size if it is 45 | is_TAG_fixarray :: Word8 -> Maybe Word32 46 | is_TAG_fixarray t 47 | | t .&. TAG_MASK_fixarray == TAG_fixarray = Just $! intCast (t .&. complement TAG_MASK_fixarray) 48 | | otherwise = Nothing 49 | {-# INLINE is_TAG_fixarray #-} 50 | 51 | pattern TAG_fixarray = 0x90 -- 0b1001xxxx [0x90 .. 0x9f] 52 | pattern TAG_MASK_fixarray = 0xf0 -- 0b11110000 53 | 54 | -- | Test whether tag is a fixstr and return embedded-size if it is 55 | is_TAG_fixstr :: Word8 -> Maybe Word32 56 | is_TAG_fixstr t 57 | | t .&. TAG_MASK_fixstr == TAG_fixstr = Just $! intCast (t .&. complement TAG_MASK_fixstr) 58 | | otherwise = Nothing 59 | {-# INLINE is_TAG_fixstr #-} 60 | 61 | pattern TAG_fixstr = 0xa0 -- 0b101xxxxx [0xa0 .. 0xbf] 62 | pattern TAG_MASK_fixstr = 0xe0 -- 0b11100000 63 | 64 | pattern TAG_nil = 0xc0 -- 0b11000000 65 | pattern TAG_reserved_C1 = 0xc1 -- 0b11000001 66 | pattern TAG_false = 0xc2 -- 0b11000010 67 | pattern TAG_true = 0xc3 -- 0b11000011 68 | 69 | pattern TAG_bin8 = 0xc4 -- 0b11000100 70 | pattern TAG_bin16 = 0xc5 -- 0b11000101 71 | pattern TAG_bin32 = 0xc6 -- 0b11000110 72 | 73 | pattern TAG_ext8 = 0xc7 -- 0b11000111 74 | pattern TAG_ext16 = 0xc8 -- 0b11001000 75 | pattern TAG_ext32 = 0xc9 -- 0b11001001 76 | 77 | pattern TAG_float32 = 0xca -- 0b11001010 78 | pattern TAG_float64 = 0xcb -- 0b11001011 79 | 80 | pattern TAG_uint8 = 0xcc -- 0b11001100 81 | pattern TAG_uint16 = 0xcd -- 0b11001101 82 | pattern TAG_uint32 = 0xce -- 0b11001110 83 | pattern TAG_uint64 = 0xcf -- 0b11001111 84 | 85 | pattern TAG_int8 = 0xd0 -- 0b11010000 86 | pattern TAG_int16 = 0xd1 -- 0b11010001 87 | pattern TAG_int32 = 0xd2 -- 0b11010010 88 | pattern TAG_int64 = 0xd3 -- 0b11010011 89 | 90 | pattern TAG_fixext1 = 0xd4 -- 0b11010100 91 | pattern TAG_fixext2 = 0xd5 -- 0b11010101 92 | pattern TAG_fixext4 = 0xd6 -- 0b11010110 93 | pattern TAG_fixext8 = 0xd7 -- 0b11010111 94 | pattern TAG_fixext16 = 0xd8 -- 0b11011000 95 | 96 | pattern TAG_str8 = 0xd9 -- 0b11011001 97 | pattern TAG_str16 = 0xda -- 0b11011010 98 | pattern TAG_str32 = 0xdb -- 0b11011011 99 | 100 | pattern TAG_array16 = 0xdc -- 0b11011100 101 | pattern TAG_array32 = 0xdd -- 0b11011101 102 | 103 | pattern TAG_map16 = 0xde -- 0b11011110 104 | pattern TAG_map32 = 0xdf -- 0b11011111 105 | 106 | -- NOTE: Currently the MessagePack specification only defines the @-1@ 107 | -- extension type (for timestamps). All remaining negative Int8 108 | -- type-ids are reserved for future use by the MessagePack. 109 | 110 | -- Used by "Data.MessagePack.Timestamp" 111 | pattern XTAG_Timestamp = -1 :: Int8 112 | -------------------------------------------------------------------------------- /msgpack/src/Data/MessagePack/Timestamp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE PatternSynonyms #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | -- | 7 | -- Module : Data.MessagePack.Integer 8 | -- Copyright : © Herbert Valerio Riedel 2019 9 | -- License : BSD3 10 | -- 11 | -- The 'MPTimestamp' type for representing MessagePack Timestamps 12 | -- 13 | -- @since 1.1.0.0 14 | module Data.MessagePack.Timestamp 15 | ( MPTimestamp 16 | 17 | , mptsFromPosixSeconds 18 | , mptsFromPosixSeconds2 19 | , mptsToPosixSeconds2 20 | 21 | , mptsFromPosixNanoseconds 22 | , mptsToPosixNanoseconds 23 | 24 | , mptsToUTCTime 25 | , mptsFromUTCTime 26 | , mptsFromUTCTimeLossy 27 | ) where 28 | 29 | import Compat.Prelude 30 | 31 | import qualified Data.ByteString as S 32 | import Data.Fixed 33 | import qualified Data.Time.Clock as Time 34 | import qualified Data.Time.Clock.POSIX as Time 35 | 36 | import Compat.Binary as Bin 37 | import Data.MessagePack.Get 38 | import Data.MessagePack.Object 39 | import Data.MessagePack.Put 40 | import Data.MessagePack.Tags 41 | 42 | -- | A MessagePack timestamp 43 | -- 44 | -- The representable range is @[-292277022657-01-27 08:29:52 UTC .. 292277026596-12-04 15:30:07.999999999 UTC]@ with nanosecond precision. 45 | -- 46 | -- @since 1.1.0.0 47 | data MPTimestamp = MPTimestamp !Int64 !Word32 48 | deriving (Eq,Ord,Show,Read,Typeable) 49 | 50 | instance Bounded MPTimestamp where 51 | minBound = MPTimestamp minBound 0 52 | maxBound = MPTimestamp maxBound 999999999 53 | 54 | instance NFData MPTimestamp where rnf (MPTimestamp _ _) = () 55 | 56 | -- | Construct 'MPTimestamp' from amount of integral seconds since Unix epoch 57 | mptsFromPosixSeconds :: Int64 -> MPTimestamp 58 | mptsFromPosixSeconds s = MPTimestamp s 0 59 | 60 | -- | Construct 'MPTimestamp' from amount of seconds and nanoseconds (must be \( \leq 10^9 \) ) passed since Unix epoch 61 | mptsFromPosixSeconds2 :: Int64 -> Word32 -> Maybe MPTimestamp 62 | mptsFromPosixSeconds2 s ns 63 | | ns <= 999999999 = Just $! MPTimestamp s ns 64 | | otherwise = Nothing 65 | 66 | -- | Deconstruct 'MPTimestamp' into amount of seconds and nanoseconds passed since Unix epoch 67 | mptsToPosixSeconds2 :: MPTimestamp -> (Int64, Word32) 68 | mptsToPosixSeconds2 (MPTimestamp s ns) = (s, ns) 69 | 70 | -- | Construct 'MPTimestamp' from total amount of nanoseconds passed since Unix epoch 71 | mptsFromPosixNanoseconds :: Integer -> Maybe MPTimestamp 72 | mptsFromPosixNanoseconds ns0 73 | | minI <= ns0, ns0 <= maxI = Just $! MPTimestamp (fromInteger s) (fromInteger ns) 74 | | otherwise = Nothing 75 | where 76 | (s,ns) = divMod ns0 1000000000 77 | maxI = mptsToPosixNanoseconds maxBound 78 | minI = mptsToPosixNanoseconds minBound 79 | 80 | -- | Deconstruct 'MPTimestamp' into total amount of nanoseconds passed since Unix epoch 81 | mptsToPosixNanoseconds :: MPTimestamp -> Integer 82 | mptsToPosixNanoseconds (MPTimestamp s ns) = (toInteger s * 1000000000) + toInteger ns 83 | 84 | -- >>> mptsToUTCTime minBound 85 | -- -292277022657-01-27 08:29:52 UTC 86 | 87 | -- >>> mptsToUTCTime maxBound 88 | -- 292277026596-12-04 15:30:07.999999999 UTC 89 | 90 | -- >>> mptsToUTCTime (MPTimestamp 0 0) 91 | -- 1970-01-01 00:00:00 UTC 92 | 93 | -- >>> mptsToUTCTime (MPTimestamp 0xffffffff 0) 94 | -- 2106-02-07 06:28:15 UTC 95 | 96 | -- >>> mptsToUTCTime (MPTimestamp 0x3ffffffff 999999999) 97 | -- 2514-05-30 01:53:03.999999999 UTC 98 | 99 | -- | Convert 'MPTimestamp' into 'Time.UTCTime' 100 | mptsToUTCTime :: MPTimestamp -> Time.UTCTime 101 | mptsToUTCTime = picoseconds2utc . (*1000) . mptsToPosixNanoseconds 102 | 103 | -- >>> mptsFromUTCTime (mptsToUTCTime minBound) == Just minBound 104 | -- True 105 | 106 | -- >>> mptsFromUTCTime (mptsToUTCTime maxBound) == Just maxBound 107 | -- True 108 | 109 | utc2picoseconds :: Time.UTCTime -> Integer 110 | utc2picoseconds utc = ps 111 | where -- NB: this exploits the RULE from time: 112 | -- "realToFrac/NominalDiffTime->Pico" realToFrac = \(MkNominalDiffTime ps) -> ps 113 | MkFixed ps = realToFrac (Time.utcTimeToPOSIXSeconds utc) :: Pico 114 | 115 | -- NB: exploits the RULE 116 | -- "realToFrac/Pico->NominalDiffTime" realToFrac = MkNominalDiffTime 117 | picoseconds2utc :: Integer -> Time.UTCTime 118 | picoseconds2utc ps = Time.posixSecondsToUTCTime (realToFrac (MkFixed ps :: Pico)) 119 | 120 | -- | Convert 'Time.UTCTime' into 'MPTimestamp' 121 | -- 122 | -- This conversion can fail (i.e. result in 'Nothing') if either the conversion cannot be performed lossless, either because the range of 'MPTimestamp' was exceeded or because of sub-nanosecond fractions. 123 | -- 124 | -- See also 'mptsFromUTCTimeLossy' 125 | mptsFromUTCTime :: Time.UTCTime -> Maybe MPTimestamp 126 | mptsFromUTCTime t 127 | | rest /= 0 = Nothing 128 | | otherwise = mptsFromPosixNanoseconds ns0 129 | where 130 | (ns0,rest) = divMod (utc2picoseconds t) 1000 131 | 132 | -- | Version of 'mptsFromUTCTime' which performs a lossy conversion into 'MPTimestamp' 133 | -- 134 | -- * sub-nanosecond precision is silently truncated (in the sense of 'floor') to nanosecond precision 135 | -- 136 | -- * time values exceeding the range of 'MPTimestamp' are clamped to 'minBound' and 'maxBound' respectively 137 | -- 138 | mptsFromUTCTimeLossy :: Time.UTCTime -> MPTimestamp 139 | mptsFromUTCTimeLossy t 140 | | Just mpts <- mptsFromPosixNanoseconds ns0 = mpts 141 | | ns0 < 0 = minBound 142 | | otherwise = maxBound 143 | where 144 | ns0 = div (utc2picoseconds t) 1000 145 | 146 | ---------------------------------------------------------------------------- 147 | 148 | instance MessagePack MPTimestamp where 149 | toObject = ObjectExt XTAG_Timestamp . mptsEncode 150 | 151 | fromObject = \case 152 | ObjectExt XTAG_Timestamp bs -> mptsDecode bs 153 | obj -> typeMismatch "MPTimestamp" obj 154 | 155 | -- helpers for 'MessagePack' instance 156 | mptsEncode :: MPTimestamp -> S.ByteString 157 | mptsEncode = runPut' . snd . mptsPutExtData 158 | 159 | mptsDecode :: S.ByteString -> Result MPTimestamp 160 | mptsDecode bs = do 161 | len <- maybe (fail "invalid data-length for Timestamp") pure $ intCastMaybe (S.length bs) 162 | either fail pure $ runGet' bs (mptsGetExtData len) 163 | 164 | -- | This 'Binary' instance encodes\/decodes to\/from MessagePack format 165 | instance Bin.Binary MPTimestamp where 166 | get = getExt' $ \typ sz -> do 167 | unless (typ == XTAG_Timestamp) $ fail "invalid extended type-tag for Timestamp" 168 | mptsGetExtData sz 169 | 170 | put = putExt' XTAG_Timestamp . mptsPutExtData 171 | 172 | mptsPutExtData :: MPTimestamp -> (Word32,Bin.Put) 173 | mptsPutExtData (MPTimestamp sec ns) 174 | | ns == 0, Just sec' <- intCastMaybe sec = (4, Bin.putWord32be sec') 175 | | 0 <= sec, sec <= 0x3ffffffff = (8, do 176 | let s' = ((intCast ns :: Word64) `shiftL` 34) .|. (fromIntegral sec) 177 | Bin.putWord64be s') 178 | | otherwise = (12, do 179 | Bin.putWord32be ns 180 | Bin.putInt64be sec) 181 | 182 | mptsGetExtData :: Word32 -> Bin.Get MPTimestamp 183 | mptsGetExtData = \case 184 | 4 -> do 185 | s <- Bin.getWord32be 186 | pure $! MPTimestamp (intCast s) 0 187 | 188 | 8 -> do 189 | dat <- Bin.getWord64be 190 | let s = fromIntegral (dat .&. 0x3ffffffff) 191 | ns = fromIntegral (dat `shiftR` 34) 192 | when (ns > 999999999) $ fail "invalid nanosecond value" 193 | pure $! MPTimestamp s ns 194 | 195 | 12 -> do 196 | ns <- Bin.getWord32be 197 | s <- Bin.getInt64be 198 | when (ns > 999999999) $ fail "invalid nanosecond value" 199 | pure $! MPTimestamp s ns 200 | 201 | _ -> fail "unsupported timestamp encoding (length)" 202 | -------------------------------------------------------------------------------- /msgpack/test/DataCases.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module DataCases (genDataCases) where 4 | 5 | import Control.Applicative as App 6 | import Control.Monad 7 | import qualified Data.ByteString as BS 8 | import qualified Data.ByteString.Char8 as S 9 | import qualified Data.ByteString.Lazy.Char8 as L 10 | import Data.Char 11 | import qualified Data.Map as Map 12 | import Data.Text (Text) 13 | import qualified Data.Text as T 14 | import Data.Word 15 | import Data.YAML as Y 16 | import qualified GHC.Exts as Lst (fromList) 17 | import System.FilePath 18 | import Test.Tasty 19 | import Test.Tasty.HUnit 20 | 21 | import Data.MessagePack hiding ((.:), (.=)) 22 | import Data.MessagePack.Timestamp 23 | 24 | genDataCases :: [FilePath] -> IO TestTree 25 | genDataCases fns = testGroup "Reference Tests" <$> forM fns doFile 26 | where 27 | doFile fn = do 28 | let fn' = "test" </> "data" </> fn <.> "yaml" 29 | raw <- S.readFile fn' 30 | let Right [cases] = Y.decodeStrict raw 31 | 32 | tcs <- forM (zip [1..] cases) $ \(i,tc) -> do 33 | -- print (tc :: DataCase) 34 | App.pure $ testCase ("testcase #" ++ show (i::Int)) $ do 35 | -- test forward direction 36 | let b0 = L.toStrict $ pack obj 37 | obj = dcObject tc 38 | assertBool ("pack " ++ show obj) (b0 `elem` dcMsgPack tc) 39 | 40 | forM_ (zip [0..] (dcMsgPack tc)) $ \(j,b) -> do 41 | let Right decoded = unpack (L.fromStrict b) 42 | 43 | packLbl = "pack #" ++ (show (j::Int)) 44 | unpackLbl = "un" ++ packLbl 45 | 46 | -- the `number` test-cases conflate integers and floats 47 | case (obj, decoded) of 48 | (ObjectDouble x, ObjectFloat _) -> do 49 | let obj' = ObjectFloat (realToFrac x) 50 | assertEqual packLbl b (L.toStrict $ pack obj') 51 | assertEqual unpackLbl obj' decoded 52 | 53 | (ObjectInt x, ObjectFloat _) -> do 54 | let obj' = ObjectFloat (fromIntegral x) 55 | assertEqual packLbl b (L.toStrict $ pack obj') 56 | assertEqual unpackLbl obj' decoded 57 | 58 | (ObjectInt x, ObjectDouble _) -> do 59 | let obj' = ObjectDouble (fromIntegral x) 60 | assertEqual packLbl b (L.toStrict $ pack obj') 61 | assertEqual unpackLbl obj' decoded 62 | 63 | _ -> assertEqual unpackLbl obj decoded 64 | 65 | pure () 66 | 67 | pure (testGroup fn tcs) 68 | 69 | 70 | data DataCase = DataCase 71 | { dcMsgPack :: [BS.ByteString] 72 | , dcObject :: Object 73 | } deriving Show 74 | 75 | instance FromYAML DataCase where 76 | parseYAML = Y.withMap "DataCase" $ \m -> do 77 | msgpack <- m .: "msgpack" 78 | 79 | obj <- do { Just (Y.Scalar Y.SNull) <- m .:! "nil" ; pure ObjectNil } 80 | <|> do { Just b <- m .:! "bool" ; pure (ObjectBool b) } 81 | <|> do { Just i <- m .:! "number" ; pure (ObjectInt (fromInteger i)) } 82 | <|> do { Just s <- m .:! "bignum" ; pure (ObjectInt (read . T.unpack $ s)) } 83 | <|> do { Just d <- m .:! "number" ; pure (ObjectDouble d) } 84 | <|> do { Just t <- m .:! "string" ; pure (ObjectStr t) } 85 | <|> do { Just t <- m .:! "binary" ; pure (ObjectBin (hex2bin t)) } 86 | <|> do { Just v@(Y.Sequence _ _) <- m .:! "array" ; pure (nodeToObj v) } 87 | <|> do { Just m'@(Y.Mapping _ _) <- m .:! "map" ; pure (nodeToObj m') } 88 | <|> do { Just (n,t) <- m .:! "ext" ; pure (ObjectExt n (hex2bin t)) } 89 | <|> do { Just (s,ns) <- m .:! "timestamp"; pure (toObject $ mptsFromPosixSeconds2 s ns) } 90 | 91 | pure (DataCase { dcMsgPack = map hex2bin msgpack, dcObject = obj }) 92 | 93 | 94 | nodeToObj :: Y.Node -> Object 95 | nodeToObj (Y.Scalar sca) = scalarToObj sca 96 | nodeToObj (Y.Sequence _ ns) = ObjectArray (Lst.fromList (map nodeToObj ns)) 97 | nodeToObj (Y.Mapping _ ns) = ObjectMap (Lst.fromList $ map (\(k,v) -> (nodeToObj k, nodeToObj v)) $ Map.toList ns) 98 | nodeToObj (Y.Anchor _ n) = nodeToObj n 99 | 100 | scalarToObj :: Y.Scalar -> Object 101 | scalarToObj Y.SNull = ObjectNil 102 | scalarToObj (Y.SBool b) = ObjectBool b 103 | scalarToObj (Y.SFloat x) = ObjectDouble x 104 | scalarToObj (Y.SInt i) = ObjectInt (fromInteger i) 105 | scalarToObj (SStr t) = ObjectStr t 106 | scalarToObj (SUnknown _ _) = error "scalarToValue" 107 | 108 | hex2bin :: Text -> S.ByteString 109 | hex2bin t 110 | | T.null t = BS.empty 111 | | otherwise = BS.pack (map f $ T.split (=='-') t) 112 | where 113 | f :: T.Text -> Word8 114 | f x | T.all isHexDigit x, [d1,d2] <- T.unpack x = read (['0','x',d1,d2]) 115 | | otherwise = error ("hex2bin: " ++ show x) 116 | -------------------------------------------------------------------------------- /msgpack/test/Properties.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | {-# OPTIONS_GHC -fno-warn-orphans #-} 4 | 5 | module Properties (idPropTests) where 6 | 7 | import Control.Applicative as App 8 | import qualified Data.ByteString.Char8 as S 9 | import qualified Data.ByteString.Lazy.Char8 as L 10 | import Data.Int 11 | import Data.Maybe 12 | import Data.Word 13 | import Test.QuickCheck 14 | import Test.Tasty 15 | import Test.Tasty.QuickCheck 16 | 17 | import Data.MessagePack 18 | import Data.MessagePack.Timestamp 19 | 20 | instance Arbitrary a => Arbitrary (Assoc a) where 21 | arbitrary = Assoc App.<$> arbitrary 22 | 23 | instance Arbitrary S.ByteString where 24 | arbitrary = S.pack <$> arbitrary 25 | 26 | instance Arbitrary L.ByteString where 27 | arbitrary = L.pack <$> arbitrary 28 | 29 | instance Arbitrary MPTimestamp where 30 | arbitrary = frequency 31 | [ (1, fromJust . mptsFromPosixNanoseconds <$> choose (mptsToPosixNanoseconds minBound, mptsToPosixNanoseconds maxBound)) 32 | , (1, mptsFromPosixSeconds <$> arbitrary) 33 | , (1, fromJust . mptsFromPosixNanoseconds <$> choose (0, 0x400000000 * 1000000000)) 34 | ] 35 | 36 | mid :: MessagePack a => a -> a 37 | mid = either error id . unpack . pack 38 | 39 | idPropTests :: TestTree 40 | idPropTests = testGroup "Identity Properties" 41 | [ testProperty "int" $ 42 | \(a :: Int) -> a == mid a 43 | , testProperty "word" $ 44 | \(a :: Word) -> a == mid a 45 | , testProperty "nil" $ 46 | \(a :: ()) -> a == mid a 47 | , testProperty "bool" $ 48 | \(a :: Bool) -> a == mid a 49 | , testProperty "float" $ 50 | \(a :: Float) -> a == mid a 51 | , testProperty "double" $ 52 | \(a :: Double) -> a == mid a 53 | , testProperty "string" $ 54 | \(a :: String) -> a == mid a 55 | , testProperty "bytestring" $ 56 | \(a :: S.ByteString) -> a == mid a 57 | , testProperty "lazy-bytestring" $ 58 | \(a :: L.ByteString) -> a == mid a 59 | , testProperty "maybe int" $ 60 | \(a :: (Maybe Int)) -> a == mid a 61 | , testProperty "[int]" $ 62 | \(a :: [Int]) -> a == mid a 63 | , testProperty "[()]" $ 64 | \(a :: [()]) -> a == mid a 65 | , testProperty "[string]" $ 66 | \(a :: [String]) -> a == mid a 67 | , testProperty "(int, int)" $ 68 | \(a :: (Int, Int)) -> a == mid a 69 | , testProperty "(int, int, int)" $ 70 | \(a :: (Int, Int, Int)) -> a == mid a 71 | , testProperty "(int, int, int, int)" $ 72 | \(a :: (Int, Int, Int, Int)) -> a == mid a 73 | , testProperty "(int8, int16, int32, int64)" $ 74 | \(a :: (Int8, Int16, Int32, Int64)) -> a == mid a 75 | , testProperty "(word,word8, word16, word32, word64)" $ 76 | \(a :: (Word, Word8, Word16, Word32, Word64)) -> a == mid a 77 | , testProperty "(int, int, int, int, int)" $ 78 | \(a :: (Int, Int, Int, Int, Int)) -> a == mid a 79 | , testProperty "[(int, double)]" $ 80 | \(a :: [(Int, Double)]) -> a == mid a 81 | , testProperty "[(string, string)]" $ 82 | \(a :: [(String, String)]) -> a == mid a 83 | , testProperty "Assoc [(string, int)]" $ 84 | \(a :: Assoc [(String, Int)]) -> a == mid a 85 | , testProperty "MPTimestamp" $ 86 | \(a :: MPTimestamp) -> a == mid a 87 | , testProperty "maybe (Int,Bool,String)" $ 88 | \(a :: (Maybe ((),Maybe Int,Maybe Float,Maybe Bool,Maybe Double,Maybe String))) -> a == mid a 89 | ] 90 | -------------------------------------------------------------------------------- /msgpack/test/data/10.nil.yaml: -------------------------------------------------------------------------------- 1 | # nil 2 | 3 | # nil 4 | - nil: null 5 | msgpack: 6 | - "c0" 7 | -------------------------------------------------------------------------------- /msgpack/test/data/11.bool.yaml: -------------------------------------------------------------------------------- 1 | # bool 2 | 3 | # false 4 | - bool: false 5 | msgpack: 6 | - "c2" 7 | 8 | # true 9 | - bool: true 10 | msgpack: 11 | - "c3" 12 | -------------------------------------------------------------------------------- /msgpack/test/data/12.binary.yaml: -------------------------------------------------------------------------------- 1 | # binary 2 | 3 | # [] // empty 4 | - binary: "" 5 | msgpack: 6 | - "c4-00" 7 | - "c5-00-00" 8 | - "c6-00-00-00-00" 9 | 10 | # [1] 11 | - binary: "01" 12 | msgpack: 13 | - "c4-01-01" 14 | - "c5-00-01-01" 15 | - "c6-00-00-00-01-01" 16 | 17 | # [0, 255] 18 | - binary: "00-ff" 19 | msgpack: 20 | - "c4-02-00-ff" 21 | - "c5-00-02-00-ff" 22 | - "c6-00-00-00-02-00-ff" 23 | -------------------------------------------------------------------------------- /msgpack/test/data/20.number-positive.yaml: -------------------------------------------------------------------------------- 1 | # number-positive 2 | # 3 | # unsigned 32bit integer 4 | 5 | # 0x0000 6 | - number: 0 7 | msgpack: 8 | - "00" # 0 ... 127 9 | - "cc-00" # unsigned int8 10 | - "cd-00-00" # unsigned int16 11 | - "ce-00-00-00-00" # unsigned int32 12 | - "cf-00-00-00-00-00-00-00-00" # unsigned int64 13 | - "d0-00" # signed int8 14 | - "d1-00-00" # signed int16 15 | - "d2-00-00-00-00" # signed int32 16 | - "d3-00-00-00-00-00-00-00-00" # signed int64 17 | - "ca-00-00-00-00" # float 18 | - "cb-00-00-00-00-00-00-00-00" # double 19 | 20 | # 0x0001 21 | - number: 1 22 | msgpack: 23 | - "01" 24 | - "cc-01" 25 | - "cd-00-01" 26 | - "ce-00-00-00-01" 27 | - "cf-00-00-00-00-00-00-00-01" 28 | - "d0-01" 29 | - "d1-00-01" 30 | - "d2-00-00-00-01" 31 | - "d3-00-00-00-00-00-00-00-01" 32 | - "ca-3f-80-00-00" 33 | - "cb-3f-f0-00-00-00-00-00-00" 34 | 35 | # 0x007F 36 | - number: 127 37 | msgpack: 38 | - "7f" 39 | - "cc-7f" 40 | - "cd-00-7f" 41 | - "ce-00-00-00-7f" 42 | - "cf-00-00-00-00-00-00-00-7f" 43 | - "d0-7f" 44 | - "d1-00-7f" 45 | - "d2-00-00-00-7f" 46 | - "d3-00-00-00-00-00-00-00-7f" 47 | 48 | # 0x0080 49 | - number: 128 50 | msgpack: 51 | - "cc-80" 52 | - "cd-00-80" 53 | - "ce-00-00-00-80" 54 | - "cf-00-00-00-00-00-00-00-80" 55 | - "d1-00-80" 56 | - "d2-00-00-00-80" 57 | - "d3-00-00-00-00-00-00-00-80" 58 | 59 | # 0x00FF 60 | - number: 255 61 | msgpack: 62 | - "cc-ff" 63 | - "cd-00-ff" 64 | - "ce-00-00-00-ff" 65 | - "cf-00-00-00-00-00-00-00-ff" 66 | - "d1-00-ff" 67 | - "d2-00-00-00-ff" 68 | - "d3-00-00-00-00-00-00-00-ff" 69 | 70 | # 0x0100 71 | - number: 256 72 | msgpack: 73 | - "cd-01-00" 74 | - "ce-00-00-01-00" 75 | - "cf-00-00-00-00-00-00-01-00" 76 | - "d1-01-00" 77 | - "d2-00-00-01-00" 78 | - "d3-00-00-00-00-00-00-01-00" 79 | 80 | # 0xFFFF 81 | - number: 65535 82 | msgpack: 83 | - "cd-ff-ff" 84 | - "ce-00-00-ff-ff" 85 | - "cf-00-00-00-00-00-00-ff-ff" 86 | - "d2-00-00-ff-ff" 87 | - "d3-00-00-00-00-00-00-ff-ff" 88 | 89 | # 0x000100000 90 | - number: 65536 91 | msgpack: 92 | - "ce-00-01-00-00" 93 | - "cf-00-00-00-00-00-01-00-00" 94 | - "d2-00-01-00-00" 95 | - "d3-00-00-00-00-00-01-00-00" 96 | 97 | # 0x7FFFFFFF 98 | - number: 2147483647 99 | msgpack: 100 | - "ce-7f-ff-ff-ff" 101 | - "cf-00-00-00-00-7f-ff-ff-ff" 102 | - "d2-7f-ff-ff-ff" 103 | - "d3-00-00-00-00-7f-ff-ff-ff" 104 | 105 | # 0x80000000 106 | - number: 2147483648 107 | msgpack: 108 | - "ce-80-00-00-00" # unsigned int32 109 | - "cf-00-00-00-00-80-00-00-00" # unsigned int64 110 | - "d3-00-00-00-00-80-00-00-00" # signed int64 111 | - "ca-4f-00-00-00" # float 112 | - "cb-41-e0-00-00-00-00-00-00" # double 113 | 114 | # 0xFFFFFFFF 115 | - number: 4294967295 116 | msgpack: 117 | - "ce-ff-ff-ff-ff" 118 | - "cf-00-00-00-00-ff-ff-ff-ff" 119 | - "d3-00-00-00-00-ff-ff-ff-ff" 120 | - "cb-41-ef-ff-ff-ff-e0-00-00" 121 | -------------------------------------------------------------------------------- /msgpack/test/data/21.number-negative.yaml: -------------------------------------------------------------------------------- 1 | # number-negative 2 | # 3 | # signed 32bit integer 4 | 5 | # 0xFFFFFFFF 6 | - number: -1 7 | msgpack: 8 | - "ff" # -1 ... -32 9 | - "d0-ff" # signed int8 10 | - "d1-ff-ff" # signed int16 11 | - "d2-ff-ff-ff-ff" # signed int32 12 | - "d3-ff-ff-ff-ff-ff-ff-ff-ff" # signed int64 13 | - "ca-bf-80-00-00" # float 14 | - "cb-bf-f0-00-00-00-00-00-00" # double 15 | 16 | # 0xFFFFFFE0 17 | - number: -32 18 | msgpack: 19 | - "e0" 20 | - "d0-e0" 21 | - "d1-ff-e0" 22 | - "d2-ff-ff-ff-e0" 23 | - "d3-ff-ff-ff-ff-ff-ff-ff-e0" 24 | - "ca-c2-00-00-00" 25 | - "cb-c0-40-00-00-00-00-00-00" 26 | 27 | # 0xFFFFFFDF 28 | - number: -33 29 | msgpack: 30 | - "d0-df" 31 | - "d1-ff-df" 32 | - "d2-ff-ff-ff-df" 33 | - "d3-ff-ff-ff-ff-ff-ff-ff-df" 34 | 35 | # 0xFFFFFF80 36 | - number: -128 37 | msgpack: 38 | - "d0-80" 39 | - "d1-ff-80" 40 | - "d2-ff-ff-ff-80" 41 | - "d3-ff-ff-ff-ff-ff-ff-ff-80" 42 | 43 | # 0xFFFFFF00 44 | - number: -256 45 | msgpack: 46 | - "d1-ff-00" 47 | - "d2-ff-ff-ff-00" 48 | - "d3-ff-ff-ff-ff-ff-ff-ff-00" 49 | 50 | # 0xFFFF8000 51 | - number: -32768 52 | msgpack: 53 | - "d1-80-00" 54 | - "d2-ff-ff-80-00" 55 | - "d3-ff-ff-ff-ff-ff-ff-80-00" 56 | 57 | # 0xFFFF0000 58 | - number: -65536 59 | msgpack: 60 | - "d2-ff-ff-00-00" 61 | - "d3-ff-ff-ff-ff-ff-ff-00-00" 62 | 63 | # 0x80000000 64 | - number: -2147483648 65 | msgpack: 66 | - "d2-80-00-00-00" 67 | - "d3-ff-ff-ff-ff-80-00-00-00" 68 | - "cb-c1-e0-00-00-00-00-00-00" 69 | -------------------------------------------------------------------------------- /msgpack/test/data/22.number-float.yaml: -------------------------------------------------------------------------------- 1 | # number-float 2 | # 3 | # decimal fraction 4 | 5 | # +0.5 6 | - number: 0.5 7 | msgpack: 8 | - "ca-3f-00-00-00" 9 | - "cb-3f-e0-00-00-00-00-00-00" 10 | 11 | # -0.5 12 | - number: -0.5 13 | msgpack: 14 | - "ca-bf-00-00-00" 15 | - "cb-bf-e0-00-00-00-00-00-00" 16 | -------------------------------------------------------------------------------- /msgpack/test/data/23.number-bignum.yaml: -------------------------------------------------------------------------------- 1 | # number-bignum 2 | # 3 | # 64bit integer 4 | 5 | # +0x0000000100000000 = +4294967296 6 | - number: 4294967296 7 | bignum: "4294967296" 8 | msgpack: 9 | - "cf-00-00-00-01-00-00-00-00" # unsigned int64 10 | - "d3-00-00-00-01-00-00-00-00" # signed int64 11 | - "ca-4f-80-00-00" # float 12 | - "cb-41-f0-00-00-00-00-00-00" # double 13 | 14 | # -0x0000000100000000 = -4294967296 15 | - number: -4294967296 16 | bignum: "-4294967296" 17 | msgpack: 18 | - "d3-ff-ff-ff-ff-00-00-00-00" # signed int64 19 | - "cb-c1-f0-00-00-00-00-00-00" # double 20 | 21 | # +0x0001000000000000 = +281474976710656 22 | - number: 281474976710656 23 | bignum: "281474976710656" 24 | msgpack: 25 | - "cf-00-01-00-00-00-00-00-00" # unsigned int64 26 | - "d3-00-01-00-00-00-00-00-00" # signed int64 27 | - "ca-57-80-00-00" # float 28 | - "cb-42-f0-00-00-00-00-00-00" # double 29 | 30 | # -0x0001000000000000 = -281474976710656 31 | - number: -281474976710656 32 | bignum: "-281474976710656" 33 | msgpack: 34 | - "d3-ff-ff-00-00-00-00-00-00" # signed int64 35 | - "ca-d7-80-00-00" # float 36 | - "cb-c2-f0-00-00-00-00-00-00" # double 37 | 38 | # JSON could not hold big numbers below 39 | 40 | # +0x7FFFFFFFFFFFFFFF = +9223372036854775807 41 | - bignum: "9223372036854775807" 42 | msgpack: 43 | - "d3-7f-ff-ff-ff-ff-ff-ff-ff" # signed int64 44 | - "cf-7f-ff-ff-ff-ff-ff-ff-ff" # unsigned int64 45 | 46 | # -0x7FFFFFFFFFFFFFFF = -9223372036854775807 47 | - bignum: "-9223372036854775807" 48 | msgpack: 49 | - "d3-80-00-00-00-00-00-00-01" # signed int64 50 | 51 | # +0x8000000000000000 = +9223372036854775808 52 | - bignum: "9223372036854775808" 53 | msgpack: 54 | - "cf-80-00-00-00-00-00-00-00" # unsigned int64 55 | 56 | # -0x8000000000000000 = -9223372036854775808 57 | - bignum: "-9223372036854775808" 58 | msgpack: 59 | - "d3-80-00-00-00-00-00-00-00" # signed int64 60 | 61 | # +0xFFFFFFFFFFFFFFFF = +18446744073709551615 62 | - bignum: "18446744073709551615" 63 | msgpack: 64 | - "cf-ff-ff-ff-ff-ff-ff-ff-ff" # unsigned int64 65 | -------------------------------------------------------------------------------- /msgpack/test/data/30.string-ascii.yaml: -------------------------------------------------------------------------------- 1 | # string-ascii 2 | 3 | # '' // empty string 4 | - string: "" 5 | msgpack: 6 | - "a0" 7 | - "d9-00" 8 | - "da-00-00" 9 | - "db-00-00-00-00" 10 | 11 | # "a" 12 | - string: "a" 13 | msgpack: 14 | - "a1-61" 15 | - "d9-01-61" 16 | - "da-00-01-61" 17 | - "db-00-00-00-01-61" 18 | 19 | # "1234567890123456789012345678901" 20 | - string: "1234567890123456789012345678901" 21 | msgpack: 22 | - "bf-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" 23 | - "d9-1f-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" 24 | - "da-00-1f-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31" 25 | 26 | # "12345678901234567890123456789012" 27 | - string: "12345678901234567890123456789012" 28 | msgpack: 29 | - "d9-20-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32" 30 | - "da-00-20-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32-33-34-35-36-37-38-39-30-31-32" 31 | -------------------------------------------------------------------------------- /msgpack/test/data/31.string-utf8.yaml: -------------------------------------------------------------------------------- 1 | # string-utf8 2 | 3 | # "Кириллица" // Russian Cyrillic alphabet 4 | - string: "Кириллица" 5 | msgpack: 6 | - "b2-d0-9a-d0-b8-d1-80-d0-b8-d0-bb-d0-bb-d0-b8-d1-86-d0-b0" 7 | - "d9-12-d0-9a-d0-b8-d1-80-d0-b8-d0-bb-d0-bb-d0-b8-d1-86-d0-b0" 8 | 9 | # "ひらがな" // Japanese Hiragana character 10 | - string: "ひらがな" 11 | msgpack: 12 | - "ac-e3-81-b2-e3-82-89-e3-81-8c-e3-81-aa" 13 | - "d9-0c-e3-81-b2-e3-82-89-e3-81-8c-e3-81-aa" 14 | 15 | # "한글" // Korean Hangul character 16 | - string: "한글" 17 | msgpack: 18 | - "a6-ed-95-9c-ea-b8-80" 19 | - "d9-06-ed-95-9c-ea-b8-80" 20 | 21 | # "汉字" // Simplified Chinese character 22 | - string: "汉字" 23 | msgpack: 24 | - "a6-e6-b1-89-e5-ad-97" 25 | - "d9-06-e6-b1-89-e5-ad-97" 26 | 27 | # "漢字" // Traditional Chinese character 28 | - string: "漢字" 29 | msgpack: 30 | - "a6-e6-bc-a2-e5-ad-97" 31 | - "d9-06-e6-bc-a2-e5-ad-97" 32 | -------------------------------------------------------------------------------- /msgpack/test/data/32.string-emoji.yaml: -------------------------------------------------------------------------------- 1 | # string-emoji 2 | 3 | # "❤" // U+2764 HEAVY BLACK HEART 4 | - string: "❤" 5 | msgpack: 6 | - "a3-e2-9d-a4" 7 | - "d9-03-e2-9d-a4" 8 | 9 | # "🍺" // U+1F37A BEER MUG 10 | - string: "🍺" 11 | msgpack: 12 | - "a4-f0-9f-8d-ba" 13 | - "d9-04-f0-9f-8d-ba" 14 | -------------------------------------------------------------------------------- /msgpack/test/data/40.array.yaml: -------------------------------------------------------------------------------- 1 | # array 2 | 3 | # [] // empty 4 | - array: [] 5 | msgpack: 6 | - "90" 7 | - "dc-00-00" 8 | - "dd-00-00-00-00" 9 | 10 | # [1] 11 | - array: [1] 12 | msgpack: 13 | - "91-01" 14 | - "dc-00-01-01" 15 | - "dd-00-00-00-01-01" 16 | 17 | # [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] 18 | - array: [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15] 19 | msgpack: 20 | - "9f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" 21 | - "dc-00-0f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" 22 | - "dd-00-00-00-0f-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f" 23 | 24 | # [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] 25 | - array: [1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16] 26 | msgpack: 27 | - "dc-00-10-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f-10" 28 | - "dd-00-00-00-10-01-02-03-04-05-06-07-08-09-0a-0b-0c-0d-0e-0f-10" 29 | 30 | # ['a'] 31 | - array: ["a"] 32 | msgpack: 33 | - "91-a1-61" 34 | - "dc-00-01-a1-61" 35 | - "dd-00-00-00-01-a1-61" 36 | -------------------------------------------------------------------------------- /msgpack/test/data/41.map.yaml: -------------------------------------------------------------------------------- 1 | # map 2 | 3 | # {} // empty 4 | - map: {} 5 | msgpack: 6 | - "80" 7 | - "de-00-00" 8 | - "df-00-00-00-00" 9 | 10 | # {a: 1} 11 | - map: {"a": 1} 12 | msgpack: 13 | - "81-a1-61-01" 14 | - "de-00-01-a1-61-01" 15 | - "df-00-00-00-01-a1-61-01" 16 | 17 | # {a: 'A'} 18 | - map: {"a": "A"} 19 | msgpack: 20 | - "81-a1-61-a1-41" 21 | - "de-00-01-a1-61-a1-41" 22 | - "df-00-00-00-01-a1-61-a1-41" 23 | -------------------------------------------------------------------------------- /msgpack/test/data/42.nested.yaml: -------------------------------------------------------------------------------- 1 | # nested 2 | 3 | # array of array 4 | - array: [[]] 5 | msgpack: 6 | - "91-90" 7 | - "dc-00-01-dc-00-00" 8 | - "dd-00-00-00-01-dd-00-00-00-00" 9 | 10 | # array of map 11 | - array: [{}] 12 | msgpack: 13 | - "91-80" 14 | - "dc-00-01-80" 15 | - "dd-00-00-00-01-80" 16 | 17 | # map of map 18 | - map: {"a": {}} 19 | msgpack: 20 | - "81-a1-61-80" 21 | - "de-00-01-a1-61-de-00-00" 22 | - "df-00-00-00-01-a1-61-df-00-00-00-00" 23 | 24 | # map of array 25 | - map: {"a": []} 26 | msgpack: 27 | - "81-a1-61-90" 28 | - "de-00-01-a1-61-90" 29 | - "df-00-00-00-01-a1-61-90" 30 | -------------------------------------------------------------------------------- /msgpack/test/data/50.timestamp.yaml: -------------------------------------------------------------------------------- 1 | # timestamp 2 | # 3 | # nanoseconds between 0000-00-00 and 9999-12-31 4 | 5 | # 2018-01-02T03:04:05.000000000Z 6 | - timestamp: [1514862245, 0] 7 | msgpack: 8 | - "d6-ff-5a-4a-f6-a5" 9 | 10 | # 2018-01-02T03:04:05.678901234Z 11 | - timestamp: [1514862245, 678901234] 12 | msgpack: 13 | - "d7-ff-a1-dc-d7-c8-5a-4a-f6-a5" 14 | 15 | # 2038-01-19T03:14:07.999999999Z 16 | - timestamp: [2147483647, 999999999] 17 | msgpack: 18 | - "d7-ff-ee-6b-27-fc-7f-ff-ff-ff" 19 | 20 | # 2038-01-19T03:14:08.000000000Z 21 | - timestamp: [2147483648, 0] 22 | msgpack: 23 | - "d6-ff-80-00-00-00" 24 | 25 | # 2038-01-19T03:14:08.000000001Z 26 | - timestamp: [2147483648, 1] 27 | msgpack: 28 | - "d7-ff-00-00-00-04-80-00-00-00" 29 | 30 | # 2106-02-07T06:28:15.000000000Z 31 | - timestamp: [4294967295, 0] 32 | msgpack: 33 | - "d6-ff-ff-ff-ff-ff" 34 | 35 | # 2106-02-07T06:28:15.999999999Z 36 | - timestamp: [4294967295, 999999999] 37 | msgpack: 38 | - "d7-ff-ee-6b-27-fc-ff-ff-ff-ff" 39 | 40 | # 2106-02-07T06:28:16.000000000Z 41 | - timestamp: [4294967296, 0] 42 | msgpack: 43 | - "d7-ff-00-00-00-01-00-00-00-00" 44 | 45 | # 2514-05-30T01:53:03.999999999Z 46 | - timestamp: [17179869183, 999999999] 47 | msgpack: 48 | - "d7-ff-ee-6b-27-ff-ff-ff-ff-ff" 49 | 50 | # 2514-05-30T01:53:04.000000000Z 51 | - timestamp: [17179869184, 0] 52 | msgpack: 53 | - "c7-0c-ff-00-00-00-00-00-00-00-04-00-00-00-00" 54 | 55 | # 1969-12-31T23:59:59.000000000Z 56 | - timestamp: [-1, 0] 57 | msgpack: 58 | - "c7-0c-ff-00-00-00-00-ff-ff-ff-ff-ff-ff-ff-ff" 59 | 60 | # 1969-12-31T23:59:59.999999999Z 61 | - timestamp: [-1, 999999999] 62 | msgpack: 63 | - "c7-0c-ff-3b-9a-c9-ff-ff-ff-ff-ff-ff-ff-ff-ff" 64 | 65 | # 1970-01-01T00:00:00.000000000Z 66 | - timestamp: [0, 0] 67 | msgpack: 68 | - "d6-ff-00-00-00-00" 69 | 70 | # 1970-01-01T00:00:00.000000001Z 71 | - timestamp: [0, 1] 72 | msgpack: 73 | - "d7-ff-00-00-00-04-00-00-00-00" 74 | 75 | # 1970-01-01T00:00:01.000000000Z 76 | - timestamp: [1, 0] 77 | msgpack: 78 | - "d6-ff-00-00-00-01" 79 | 80 | # 1899-12-31T23:59:59.999999999Z 81 | - timestamp: [-2208988801, 999999999] 82 | msgpack: 83 | - "c7-0c-ff-3b-9a-c9-ff-ff-ff-ff-ff-7c-55-81-7f" 84 | 85 | # 1900-01-01T00:00:00.000000000Z 86 | - timestamp: [-2208988800, 0] 87 | msgpack: 88 | - "c7-0c-ff-00-00-00-00-ff-ff-ff-ff-7c-55-81-80" 89 | 90 | # 0000-01-01T00:00:00.000000000Z 91 | - timestamp: [-62167219200, 0] 92 | msgpack: 93 | - "c7-0c-ff-00-00-00-00-ff-ff-ff-f1-86-8b-84-00" 94 | 95 | # 9999-12-31T23:59:59.999999999Z 96 | - timestamp: [253402300799, 999999999] 97 | msgpack: 98 | - "c7-0c-ff-3b-9a-c9-ff-00-00-00-3a-ff-f4-41-7f" 99 | -------------------------------------------------------------------------------- /msgpack/test/data/60.ext.yaml: -------------------------------------------------------------------------------- 1 | # ext 2 | 3 | # fixext 1 4 | - ext: [1, "10"] 5 | msgpack: 6 | - "d4-01-10" 7 | 8 | # fixext 2 9 | - ext: [2, "20-21"] 10 | msgpack: 11 | - "d5-02-20-21" 12 | 13 | # fixext 4 14 | - ext: [3, "30-31-32-33"] 15 | msgpack: 16 | - "d6-03-30-31-32-33" 17 | 18 | # fixext 8 19 | - ext: [4, "40-41-42-43-44-45-46-47"] 20 | msgpack: 21 | - "d7-04-40-41-42-43-44-45-46-47" 22 | 23 | # fixext 16 24 | - ext: [5, "50-51-52-53-54-55-56-57-58-59-5a-5b-5c-5d-5e-5f"] 25 | msgpack: 26 | - "d8-05-50-51-52-53-54-55-56-57-58-59-5a-5b-5c-5d-5e-5f" 27 | 28 | # ext size=0 29 | - ext: [6, ""] 30 | msgpack: 31 | - "c7-00-06" # ext 8 32 | - "c8-00-00-06" # ext 16 33 | - "c9-00-00-00-00-06" # ext 32 34 | 35 | # ext size=3 36 | - ext: [7, "70-71-72"] 37 | msgpack: 38 | - "c7-03-07-70-71-72" # ext 8 39 | - "c8-00-03-07-70-71-72" # ext 16 40 | - "c9-00-00-00-03-07-70-71-72" # ext 32 41 | -------------------------------------------------------------------------------- /msgpack/test/data/README.md: -------------------------------------------------------------------------------- 1 | The test datasets in this folder have been downloaded from 2 | 3 | https://github.com/kawanet/msgpack-test-suite 4 | 5 | (version 1.0.0 / e04f6edeaae589c768d6b70fcce80aa786b7800e) 6 | 7 | and are subject to the license below 8 | 9 | ``` 10 | MIT License 11 | 12 | Copyright (c) 2017-2018 Yusuke Kawasaki 13 | 14 | Permission is hereby granted, free of charge, to any person obtaining a copy 15 | of this software and associated documentation files (the "Software"), to deal 16 | in the Software without restriction, including without limitation the rights 17 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 18 | copies of the Software, and to permit persons to whom the Software is 19 | furnished to do so, subject to the following conditions: 20 | 21 | The above copyright notice and this permission notice shall be included in all 22 | copies or substantial portions of the Software. 23 | 24 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 25 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 26 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 27 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 28 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 29 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 30 | SOFTWARE. 31 | ``` 32 | -------------------------------------------------------------------------------- /msgpack/test/test.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Test.Tasty 4 | 5 | import DataCases 6 | import Properties 7 | 8 | main :: IO () 9 | main = do 10 | testDataCases <- genDataCases 11 | [ "10.nil" 12 | , "11.bool" 13 | , "12.binary" 14 | , "20.number-positive" 15 | , "21.number-negative" 16 | , "22.number-float" 17 | , "23.number-bignum" 18 | , "30.string-ascii" 19 | , "31.string-utf8" 20 | , "32.string-emoji" 21 | , "40.array" 22 | , "41.map" 23 | , "42.nested" 24 | , "50.timestamp" 25 | , "60.ext" 26 | ] 27 | 28 | defaultMain (testGroup "Tests" [ idPropTests, testDataCases ]) 29 | --------------------------------------------------------------------------------