diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Philip Cunningham + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ruby-marshal.cabal b/ruby-marshal.cabal new file mode 100644 --- /dev/null +++ b/ruby-marshal.cabal @@ -0,0 +1,66 @@ +name: ruby-marshal +version: 0.0.1 +synopsis: Parse a subset of Ruby objects serialised with Marshal.dump. +description: Parse a subset of Ruby objects serialised with Marshal.dump. +homepage: https://github.com/filib/ruby-marshal +license: MIT +license-file: LICENSE +author: Philip Cunningham +maintainer: hello@filib.io +category: Data +build-type: Simple +tested-with: GHC == 7.8, GHC == 7.10 +cabal-version: >= 1.10 + +Source-repository head + type: git + location: https://github.com/filib/ruby-marshal + +flag developer + default: False + +library + if flag(developer) + ghc-options: + -fprof-auto + -rtsopts + hs-source-dirs: + src + build-depends: + base >= 4.7 && < 5 + , cereal >= 0.3.5.0 && < 0.5.0.0 + , bytestring >= 0.9.0 + , containers >= 0.5.0 + , string-conv >= 0.1 + , mtl >= 2.2 + , vector >= 0.10.0 + default-language: + Haskell2010 + exposed-modules: + Data.Ruby.Marshal + , Data.Ruby.Marshal.Get + , Data.Ruby.Marshal.Types + , Data.Ruby.Marshal.Internal.Int + +test-suite spec + ghc-options: + -Wall + hs-source-dirs: + src, test + build-depends: + base >= 4.7 && < 5 + , cereal >= 0.3.5.0 && < 0.5.0.0 + , bytestring >= 0.9.0 + , containers >= 0.5.0.0 + , hspec + , mtl >= 2.2 + , string-conv >= 0.1 + , vector >= 0.10.0 + default-language: + Haskell2010 + other-modules: + Spec + main-is: + Spec.hs + type: + exitcode-stdio-1.0 diff --git a/src/Data/Ruby/Marshal.hs b/src/Data/Ruby/Marshal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ruby/Marshal.hs @@ -0,0 +1,55 @@ +-------------------------------------------------------------------- +-- | +-- Module : Data.Ruby.Marshal +-- Copyright : (c) Philip Cunningham, 2015 +-- License : MIT +-- +-- Maintainer: hello@filib.io +-- Stability : experimental +-- Portability: portable +-- +-- Simple interface to deserialise Ruby Marshal binary. +-- +-------------------------------------------------------------------- + +module Data.Ruby.Marshal ( + -- * Simple interface to deserialise Ruby Marshal binary + decode + , decodeEither + -- * Re-exported modules + , module Data.Ruby.Marshal.Get + , module Data.Ruby.Marshal.Types +) where + +import Data.Ruby.Marshal.Get +import Data.Ruby.Marshal.Types (Cache(..), RubyObject(..), Marshal(..)) + +import Control.Monad.State (evalStateT) +import Data.Serialize (runGet) + +import qualified Data.ByteString as BS +import qualified Data.Vector as V + +-- | Deserialises a subset of Ruby objects serialised with Marshal, Ruby's +-- built-in binary serialisation format. +decode :: BS.ByteString + -- ^ Serialised Ruby object + -> Maybe RubyObject + -- ^ De-serialisation result +decode = hush . decodeEither + +-- | Deserialises a subset of Ruby objects serialised with Marshal, Ruby's +-- built-in binary serialisation format. +decodeEither :: BS.ByteString + -- ^ Serialised Ruby object + -> Either String RubyObject + -- ^ Error message or de-serialisation result +decodeEither = runGet (evalStateT (runMarshal getRubyObject) emptyCache) + +-- | Constructs an empty cache to store symbols and objects. +emptyCache :: Cache +emptyCache = Cache { _symbols = V.empty, _objects = V.empty } + +-- | Converts an Either to a Maybe. +hush :: Either a b -> Maybe b +hush = either (const Nothing) Just diff --git a/src/Data/Ruby/Marshal/Get.hs b/src/Data/Ruby/Marshal/Get.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ruby/Marshal/Get.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.Ruby.Marshal.Get +-- Copyright : (c) Philip Cunningham, 2015 +-- License : MIT +-- +-- Maintainer: hello@filib.io +-- Stability : experimental +-- Portability: portable +-- +-- Ruby Marshal deserialiser using @Data.Serialize@. +-- +-------------------------------------------------------------------- + +module Data.Ruby.Marshal.Get ( + getMarshalVersion + , getRubyObject + , getNil + , getBool + , getArray + , getFixnum + , getFloat + , getHash + , getIVar + , getObjectLink + , getString + , getSymbol + , getSymlink +) where + +import Control.Applicative +import Data.Ruby.Marshal.Internal.Int +import Data.Ruby.Marshal.Types + +import Control.Monad (guard, liftM2, replicateM) +import Control.Monad.State (get, gets, put) +import Data.Serialize.Get (Get, getBytes, getTwoOf, label) +import Data.String.Conv (toS) +import Text.Read (readMaybe) + +import qualified Data.ByteString as BS +import qualified Data.Map.Strict as DM +import qualified Data.Vector as V + +import Prelude hiding (length) + +-------------------------------------------------------------------- +-- Top-level functions. + +-- | Deserialises Marshal version. +getMarshalVersion :: Marshal (Word8, Word8) +getMarshalVersion = marshalLabel "Marshal Version" $ + getTwoOf getWord8 getWord8 + +-- | Deserialises a subset of Ruby objects. +getRubyObject :: Marshal RubyObject +getRubyObject = getMarshalVersion >> go + where + go :: Marshal RubyObject + go = liftMarshal getWord8 >>= \case + NilC -> return RNil + TrueC -> return $ RBool True + FalseC -> return $ RBool False + ArrayC -> RArray <$> getArray go + FixnumC -> RFixnum <$> getFixnum + FloatC -> RFloat <$> getFloat + HashC -> RHash <$> getHash go go + IVarC -> RIVar <$> getIVar go + ObjectLinkC -> RIVar <$> getObjectLink + StringC -> RString <$> getString + SymbolC -> RSymbol <$> getSymbol + SymlinkC -> RSymbol <$> getSymlink + _ -> return $ RError Unsupported + +-------------------------------------------------------------------- +-- Ancillary functions. + +-- | Deserialises . +getNil :: Marshal () +getNil = marshalLabel "Nil" $ tag 48 + +-- | Deserialises and +-- . +getBool :: Marshal Bool +getBool = marshalLabel "Bool" $ + True <$ tag 84 <|> False <$ tag 70 + +-- | Deserialises . +getArray :: Marshal a -> Marshal (V.Vector a) +getArray g = do + n <- getFixnum + x <- V.replicateM n g + marshalLabel "Array" $ return x + +-- | Deserialises . +getFixnum :: Marshal Int +getFixnum = marshalLabel "Fixnum" $ do + x <- getInt8 + if | x == 0 -> fromIntegral <$> return x + | x == 1 -> fromIntegral <$> getWord8 + | x == -1 -> fromIntegral <$> getNegInt16 + | x == 2 -> fromIntegral <$> getWord16le + | x == -2 -> fromIntegral <$> getInt16le + | x == 3 -> fromIntegral <$> getWord24le + | x == -3 -> fromIntegral <$> getInt24le + | x == 4 -> fromIntegral <$> getWord32le + | x == -4 -> fromIntegral <$> getInt32le + | x >= 6 -> fromIntegral <$> return (x - 5) + | x <= -6 -> fromIntegral <$> return (x + 5) + | otherwise -> empty + where + getNegInt16 :: Get Int16 + getNegInt16 = do + x <- fromIntegral <$> getInt8 + if x >= 0 && x <= 127 then return (x - 256) else return x + +-- | Deserialises . +getFloat :: Marshal Double +getFloat = do + s <- getString + x <- case readMaybe . toS $ s of + Just float -> return float + Nothing -> fail "getFloat" + marshalLabel "Float" $ return x + +-- | Deserialises . +getHash :: forall k v. Ord k => Marshal k -> Marshal v -> Marshal (DM.Map k v) +getHash k v = do + n <- getFixnum + x <- DM.fromList `fmap` replicateM n (liftM2 (,) k v) + marshalLabel "Hash" $ return x + +-- | Deserialises . +getIVar :: Marshal RubyObject -> Marshal (RubyObject, BS.ByteString) +getIVar g = do + string <- g + length <- getFixnum + if | length /= 1 -> fail "getIvar: expected single character" + | otherwise -> do + symbol <- g + denote <- g + case symbol of + RSymbol "E" -> case denote of + RBool True -> cacheAndReturn string "UTF-8" + RBool False -> cacheAndReturn string "US-ASCII" + _ -> fail "getIVar: expected bool" + RSymbol "encoding" -> case denote of + RString enc -> cacheAndReturn string enc + _ -> fail "getIVar: expected string" + _ -> fail "getIVar: invalid ivar" + where + cacheAndReturn string enc = do + let result = (string, enc) + writeCache $ RIVar result + marshalLabel "IVar" $ return result + +-- | Deserialises . +getObjectLink :: Marshal (RubyObject, BS.ByteString) +getObjectLink = do + index <- getFixnum + maybeObject <- readObject index + case maybeObject of + Just (RIVar x) -> return x + _ -> fail "getObjectLink" + +-- | Deserialises . +getString :: Marshal BS.ByteString +getString = do + n <- getFixnum + x <- liftMarshal $ getBytes n + marshalLabel "RawString" $ return x + +-- | Deserialises . +getSymbol :: Marshal BS.ByteString +getSymbol = do + x <- getString + writeCache $ RSymbol x + marshalLabel "Symbol" $ return x + +-- | Deserialises . +getSymlink :: Marshal BS.ByteString +getSymlink = do + index <- getFixnum + maybeObject <- readSymbol index + case maybeObject of + Just (RSymbol bs) -> return bs + _ -> fail "getSymlink" + +-------------------------------------------------------------------- +-- Utility functions. + +-- | Lift label into Marshal monad. +marshalLabel :: String -> Get a -> Marshal a +marshalLabel x y = liftMarshal $ label x y + +-- | Guard against invalid input. +tag :: Word8 -> Get () +tag t = label "Tag" $ + getWord8 >>= \b -> guard $ t == b + +-- | Look up object in our object cache. +readObject :: Int -> Marshal (Maybe RubyObject) +readObject index = gets _objects >>= \objectCache -> + return $ objectCache V.!? index + +-- | Look up a symbol in our symbol cache. +readSymbol :: Int -> Marshal (Maybe RubyObject) +readSymbol index = gets _symbols >>= \symbolCache -> + return $ symbolCache V.!? index + +-- | Write an object to the appropriate cache. +writeCache :: RubyObject -> Marshal () +writeCache object = do + cache <- get + case object of + RIVar _ -> put $ cache { _objects = V.snoc (_objects cache) object } + RSymbol _ -> put $ cache { _symbols = V.snoc (_symbols cache) object } + _ -> return () diff --git a/src/Data/Ruby/Marshal/Internal/Int.hs b/src/Data/Ruby/Marshal/Internal/Int.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ruby/Marshal/Internal/Int.hs @@ -0,0 +1,63 @@ +-------------------------------------------------------------------- +-- | +-- Module : Data.Ruby.Marshal.Internal.Int +-- Copyright : (c) Philip Cunningham, 2015 +-- License : MIT +-- +-- Maintainer: hello@filib.io +-- Stability : experimental +-- Portability: portable +-- +-- Helper module for parsing Int. +-- +-------------------------------------------------------------------- + +module Data.Ruby.Marshal.Internal.Int ( + -- * Signed integrals + getInt8 + , getInt16le + , getInt24le + , getInt32le + , Int16 + -- * Unsigned integrals + , getWord8 + , getWord16le + , getWord24le + , getWord32le + , Word8 +) where + +import Control.Applicative +import Prelude + +import Data.Bits ((.|.), shiftL) +import Data.Int (Int8, Int16, Int32) +import Data.Serialize.Get (Get, getBytes, getWord8, getWord16le, getWord32le) +import Data.Word (Word8, Word32) + +import qualified Data.ByteString as BS + +-- | Read an Int8. +getInt8 :: Get Int8 +getInt8 = fromIntegral <$> getWord8 + +-- | Read an Int16. +getInt16le :: Get Int16 +getInt16le = fromIntegral <$> getWord16le + +-- | Read a Word24 in little endian format. Since Word24 unavailable in Data.Int +-- we use Word32. +getWord24le :: Get Word32 +getWord24le = do + s <- getBytes 3 + return $! (fromIntegral (s `BS.index` 2) `shiftL` 16) .|. + (fromIntegral (s `BS.index` 1) `shiftL` 8) .|. + fromIntegral (s `BS.index` 0) + +-- | Read an Int24. Since Int24 unavailable in Data.Int we use Int32. +getInt24le :: Get Int32 +getInt24le = fromIntegral <$> getWord24le + +-- | Read an Int32. +getInt32le :: Get Int32 +getInt32le = fromIntegral <$> getWord32le diff --git a/src/Data/Ruby/Marshal/Types.hs b/src/Data/Ruby/Marshal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ruby/Marshal/Types.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE PatternSynonyms #-} + +module Data.Ruby.Marshal.Types where + +import Control.Applicative +import Prelude + +import Control.Monad.State (lift, MonadState, StateT) +import Data.Map (Map) +import Data.Serialize.Get (Get) +import Data.Vector (Vector) + +import qualified Data.ByteString as BS + +data Cache = Cache { + _objects :: Vector RubyObject + -- ^ object cache. + , _symbols :: Vector RubyObject + -- ^ symbol cache. + } deriving Show + +-- | Convey when unsupported object encountered. +data Error + = Unsupported + -- ^ represents an unsupported Ruby object + deriving (Eq, Ord, Show) + +-- | Marshal monad endows the underling Get monad with State. +newtype Marshal a = Marshal { + runMarshal :: StateT Cache Get a + } deriving (Functor, Applicative, Monad, MonadState Cache) + +-- | Lift Get monad into Marshal monad. +liftMarshal :: Get a -> Marshal a +liftMarshal = Marshal . lift + +-- | Representation of a Ruby object. +data RubyObject + = RNil + -- ^ represents @nil@ + | RBool !Bool + -- ^ represents @true@ or @false@ + | RFixnum {-# UNPACK #-} !Int + -- ^ represents a @Fixnum@ + | RArray !(Vector RubyObject) + -- ^ represents an @Array@ + | RHash !(Map RubyObject RubyObject) + -- ^ represents an @Hash@ + | RIVar !(RubyObject, BS.ByteString) + -- ^ represents an @IVar@ + | RString !BS.ByteString + -- ^ represents a @String@ + | RFloat {-# UNPACK #-} !Double + -- ^ represents a @Float@ + | RSymbol !BS.ByteString + -- ^ represents a @Symbol@ + | RError !Error + -- ^ represents an invalid object + deriving (Eq, Ord, Show) + +-- See docs.ruby-lang.org for more information +-- http://docs.ruby-lang.org/en/2.1.0/marshal_rdoc.html#label-Stream+Format + +-- | NilClass +pattern NilC = 48 +-- | FalseClass +pattern FalseC = 70 +-- | TrueClass +pattern TrueC = 84 +-- | Array +pattern ArrayC = 91 +-- | Fixnum +pattern FixnumC = 105 +-- | Float +pattern FloatC = 102 +-- | Hash +pattern HashC = 123 +-- | IVar +pattern IVarC = 73 +-- | Object link +pattern ObjectLinkC = 64 +-- | String +pattern StringC = 34 +-- | Symbol +pattern SymbolC = 58 +-- | Symlink +pattern SymlinkC = 59 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}