diff --git a/Data/PHPSession.hs b/Data/PHPSession.hs --- a/Data/PHPSession.hs +++ b/Data/PHPSession.hs @@ -8,8 +8,31 @@ -- Portability: portable -- -- Encodes and decodes serialized PHP sessions in the format used by the \"php\" setting --- for session.serialize_handler. +-- for session.serialize_handler, as well as encodes and decodes PHP values in general +-- in the format used by PHP's serialize/unserialize. +-- +-- An example of using 'decodePHPSessionValue' and 'convFrom' to decode and convert values +-- from the serialized contents of a 'LBS.ByteString' to @[('Int','LBS.ByteString')]@: +-- +-- > import qualified Data.PHPSession as PHPSess +-- > +-- > getArrayValues :: LBS.ByteString -> [(Int, LBS.ByteString)] +-- > getArrayValues encoded = +-- > case PHPSess.decodePHPSessionValue encoded of +-- > Nothing -> [] :: [(Int,LBS.ByteString)] +-- > Just b -> PHPSess.convFrom b -- +-- Starting from a value output from the following PHP code: +-- +-- @/ \'Hello\', 5 => \'World\'));@ +-- @\/\* Outputs: \"a:2:{i:0;s:5:\\\"Hello\\\";i:5;s:5:\\\"World\\\";}\" \*\/@ +-- +-- The following can be computed: +-- +-- >>> getArrayValues $ LBS.pack "a:2:{i:0;s:5:\"Hello\";i:5;s:5:\"World\";}" +-- [(0,"Hello"),(5,"World")] +-- +-- module Data.PHPSession ( -- * Decode from 'ByteString' @@ -20,6 +43,11 @@ -- * Encode to 'ByteString' encodePHPSession, encodePHPSessionValue, + -- * Convert to 'PHPSessionValue' + convTo, + -- * Convert from 'PHPSessionValue' + convFrom, + convFromSafe, -- * Decode only part of a 'ByteString' decodePartialPHPSessionValue, decodePartialPHPSessionValueEither, @@ -31,11 +59,13 @@ ) where import Data.PHPSession.Types +import Data.PHPSession.Conv (convTo, convFrom, convFromSafe) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.List as L import qualified Data.Char as C +import Data.List (foldl') import Data.List (foldl') diff --git a/Data/PHPSession/Conv.hs b/Data/PHPSession/Conv.hs new file mode 100644 --- /dev/null +++ b/Data/PHPSession/Conv.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE FlexibleInstances #-} +-- | +-- Module : Data.PHPSession.Conv +-- Copyright: (c) 2014 Edward Blake +-- License: BSD-style +-- Maintainer: Edward L. Blake +-- Stability: experimental +-- Portability: portable +-- +-- Non-coerced translation between 'PHPSessionValue' and various Haskell types. +-- 'convTo' provide convenient translation from native types to 'PHPSessionValue', +-- while translation from 'PHPSessionValue' to native types is provided through +-- 'convFrom' and 'convFromSafe'. +-- +module Data.PHPSession.Conv ( + -- * Convert to 'PHPSessionValue' + convTo, + -- * Convert from 'PHPSessionValue' + convFrom, + convFromSafe, + -- * Type classes + ConversionToPHPValue(..), + ConversionFromPHPValueOrMismatch(..) +) where + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as BS +import Data.PHPSession.Types +import Data.Int (Int32, Int64) +import Data.List as L (foldl') + +-- | 'convTo' is a convenience function that converts natively typed +-- values to 'PHPSessionValue', with the resulting PHP type determined +-- by the type cast or inferred. +-- +-- > arrayOfPHPStrings :: PHPSessionValue +-- > arrayOfPHPStrings = +-- > let str1 = "Hello" :: BS.ByteString +-- > str2 = "World" +-- > in convTo [(0 :: Int, str1), (1, str2)] +-- +-- In the above example code, the @OverloadedStrings@ language extension is assumed. +-- +convTo :: ConversionToPHPValue a => a -> PHPSessionValue +convTo val = convTo' val + +class ConversionToPHPValue a where + convTo' :: a -> PHPSessionValue + +class ConversionFromPHPValueOrMismatch b where + convFromOM :: PHPSessionValue -> Either String b + +instance ConversionToPHPValue PHPSessionValue where + convTo' var = var + +instance ConversionToPHPValue [(PHPSessionValue,PHPSessionValue)] where + convTo' var = PHPSessionValueArray var + +instance (ConversionToPHPValue a, ConversionToPHPValue b) => ConversionToPHPValue [(a,b)] where + convTo' var = PHPSessionValueArray $ map (\(al,ar) -> (convTo' al, convTo' ar)) var + +instance ConversionToPHPValue Bool where + convTo' var = PHPSessionValueBool var + +instance ConversionToPHPValue Double where + convTo' var = PHPSessionValueFloat (Right var) + +instance ConversionToPHPValue Int where + convTo' var = PHPSessionValueInt var + +instance ConversionToPHPValue Int32 where + convTo' var = PHPSessionValueInt (fromIntegral var) + +instance ConversionToPHPValue Int64 where + convTo' var = PHPSessionValueInt (fromIntegral var) + +instance ConversionToPHPValue a => ConversionToPHPValue (Maybe a) where + convTo' Nothing = PHPSessionValueNull + convTo' (Just var) = convTo' var + +instance ConversionToPHPValue (PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)]) where + convTo' (cls,arr) = PHPSessionValueObject cls arr + +instance ConversionToPHPValue (PHPSessionClassName, LBS.ByteString) where + convTo' (cls,arr) = PHPSessionValueObjectSerializeable cls arr + +instance ConversionToPHPValue LBS.ByteString where + convTo' var = PHPSessionValueString var + +instance ConversionToPHPValue BS.ByteString where + convTo' var = PHPSessionValueString (LBS.fromChunks [var]) + +instance ConversionFromPHPValueOrMismatch [(PHPSessionValue,PHPSessionValue)] where + convFromOM (PHPSessionValueArray var) = Right var + convFromOM v = mismatchError v "[(PHPSessionValue,PHPSessionValue)]" + +instance ConversionFromPHPValueOrMismatch a => ConversionFromPHPValueOrMismatch [(a,PHPSessionValue)] where + convFromOM (PHPSessionValueArray vars) = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + let l' = convFromOM l + in case l' of + Left errl -> Left errl + Right l'' -> + Right ((l'',r) : lst) + convFromOM v = mismatchError v "ConversionFromPHPValueOrMismatch a => ConversionFromPHPValueOrMismatch [(a,PHPSessionValue)]" + +instance ConversionFromPHPValueOrMismatch b => ConversionFromPHPValueOrMismatch [(PHPSessionValue,b)] where + convFromOM (PHPSessionValueArray vars) = + convArrayRightSide vars convFromOM + convFromOM v = mismatchError v "ConversionFromPHPValueOrMismatch b => ConversionFromPHPValueOrMismatch [(PHPSessionValue,b)]" + +convArrayRightSide vars conv = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + case conv r of + Left errr -> Left errr + Right r'' -> + Right $ (l, r'') : lst + +instance (ConversionFromPHPValueOrMismatch a, ConversionFromPHPValueOrMismatch b) => ConversionFromPHPValueOrMismatch [(a,b)] where + convFromOM (PHPSessionValueArray vars) = + convArrayBothSides vars convFromOM + convFromOM v = mismatchError v "(ConversionFromPHPValueOrMismatch a, ConversionFromPHPValueOrMismatch b) => ConversionFromPHPValueOrMismatch [(a,b)]" + +convArrayBothSides vars conv = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + let l' = convFromOM l + r' = conv r + in case l' of + Left errl -> Left errl + Right l'' -> + case r' of + Left errr -> Left errr + Right r'' -> + Right ((l'', r'') : lst) + + +instance ConversionFromPHPValueOrMismatch Bool where + convFromOM (PHPSessionValueBool var) = Right var + convFromOM v = mismatchError v "Bool" + +instance ConversionFromPHPValueOrMismatch Double where + convFromOM (PHPSessionValueFloat (Left var)) = Right $ fromIntegral var + convFromOM (PHPSessionValueFloat (Right var)) = Right var + convFromOM v = mismatchError v "Double" + +instance ConversionFromPHPValueOrMismatch Int where + convFromOM (PHPSessionValueInt var) = Right var + convFromOM v = mismatchError v "Int" + +instance ConversionFromPHPValueOrMismatch Int32 where + convFromOM (PHPSessionValueInt var) = Right $ fromIntegral var + convFromOM v = mismatchError v "Int32" + +instance ConversionFromPHPValueOrMismatch Int64 where + convFromOM (PHPSessionValueInt var) = Right $ fromIntegral var + convFromOM v = mismatchError v "Int64" + +instance Integral n => ConversionFromPHPValueOrMismatch (Either n Double) where + convFromOM (PHPSessionValueFloat (Right var)) = (Right . Right) var + convFromOM (PHPSessionValueFloat (Left var)) = (Right . Right . fromIntegral) var + convFromOM (PHPSessionValueInt var) = (Right . Left . fromIntegral) var + convFromOM v = mismatchError v "Integral n => Either n Double" + +instance Integral n => ConversionFromPHPValueOrMismatch (Either n LBS.ByteString) where + convFromOM (PHPSessionValueString var) = (Right . Right) var + convFromOM (PHPSessionValueInt var) = (Right . Left . fromIntegral) var + convFromOM v = mismatchError v "Integral n => Either n ByteString" + +instance ConversionFromPHPValueOrMismatch (Either Double LBS.ByteString) where + convFromOM (PHPSessionValueString var) = (Right . Right) var + convFromOM (PHPSessionValueFloat (Right var)) = (Right . Left ) var + convFromOM (PHPSessionValueFloat (Left var)) = (Right . Left . fromIntegral) var + convFromOM v = mismatchError v "Either Double ByteString" + +instance Integral n => ConversionFromPHPValueOrMismatch (Either n BS.ByteString) where + convFromOM (PHPSessionValueString var) = (Right . Right . BS.concat . LBS.toChunks) var + convFromOM (PHPSessionValueInt var) = (Right . Left . fromIntegral) var + convFromOM v = mismatchError v "Integral n => Either n ByteString" + +instance ConversionFromPHPValueOrMismatch (Either Double BS.ByteString) where + convFromOM (PHPSessionValueString var) = (Right . Right . BS.concat . LBS.toChunks) var + convFromOM (PHPSessionValueFloat (Right var)) = (Right . Left ) var + convFromOM (PHPSessionValueFloat (Left var)) = (Right . Left . fromIntegral) var + convFromOM v = mismatchError v "Either Double ByteString" + +instance ConversionFromPHPValueOrMismatch (PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)]) where + convFromOM (PHPSessionValueObject cls arr) = Right (cls,arr) + convFromOM v = mismatchError v "(PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)])" + +instance ConversionFromPHPValueOrMismatch (PHPSessionClassName, LBS.ByteString) where + convFromOM (PHPSessionValueObjectSerializeable cls arr) = Right (cls,arr) + convFromOM v = mismatchError v "(PHPSessionClassName, ByteString)" + +instance ConversionFromPHPValueOrMismatch LBS.ByteString where + convFromOM (PHPSessionValueString var) = Right var + convFromOM v = mismatchError v "ByteString" + +instance ConversionFromPHPValueOrMismatch BS.ByteString where + convFromOM (PHPSessionValueString var) = (Right . BS.concat . LBS.toChunks) var + convFromOM v = mismatchError v "ByteString" + +instance ConversionFromPHPValueOrMismatch a => ConversionFromPHPValueOrMismatch (Maybe a) where + convFromOM PHPSessionValueNull = Right Nothing + convFromOM v = + case convFromOM v of + Left s -> Left s + Right b' -> Right (Just b') + + +mismatchError v totype = + Left $ "Type mismatch converting from (" ++ show v ++ ") to " ++ totype + +-- | 'convFrom' and 'convFromSafe' are convenience functions that translate PHP +-- values stored as 'PHPSessionValue' into appropriate Haskell types depending on +-- the desired type cast or inferred. Functions provided in this module provide +-- non-coerced type translations and so will either carry on the translation or +-- signal the fact that the attempted conversion will alter the type of the +-- value. For situations where altering value types is expected, alternative +-- conversion functions with similar type signatures are provided in modules +-- within /Data.PHPSession.ImplicitConv/. +-- +-- The example arrayOfPHPStrings definition given in 'convTo' can be reverted back +-- to Haskell types, which evaluates to @[(0,\"Hello\"),(1,\"World\")]@. +-- +-- >>> convFrom arrayOfPHPStrings :: [(Int,LBS.ByteString)] +-- [(0,"Hello"),(1,"World")] +-- +-- However, if the desired type signature is changed to a completely different type, +-- then a runtime exception is thrown: +-- +-- >>> convFrom arrayOfPHPStrings :: [(Int,Int)] +-- *** Exception: Type mismatch converting from (PHPSessionValueString "Hello") to Int +-- +-- Where there is the possibility that the value being sought may be @/NULL/@, the +-- type should be @('Maybe' a)@. +-- +convFrom :: ConversionFromPHPValueOrMismatch b => PHPSessionValue -> b +convFrom var = + case convFromOM var of + Left message -> error message + Right var' -> var' + +-- | A version of 'convFrom' which returns a 'Left' with an error message instead +-- of throwing an exception. +-- +convFromSafe + :: ConversionFromPHPValueOrMismatch b => + PHPSessionValue -> Either String b +convFromSafe var = convFromOM var + diff --git a/Data/PHPSession/ImplicitConv/ConvBool.hs b/Data/PHPSession/ImplicitConv/ConvBool.hs new file mode 100644 --- /dev/null +++ b/Data/PHPSession/ImplicitConv/ConvBool.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.PHPSession.ImplicitConv.ConvBool +-- Copyright: (c) 2014 Edward Blake +-- License: BSD-style +-- Maintainer: Edward L. Blake +-- Stability: experimental +-- Portability: portable +-- +-- Non-coerced and coerced rule sets for converting 'PHPSessionValue' objects to 'Bool'. +-- +module Data.PHPSession.ImplicitConv.ConvBool ( + -- * Non-coerced from 'PHPSessionValue' + boolDefaultFalseFrom, + boolDefaultTrueFrom, + -- * Type coercion from 'PHPSessionValue' + boolFromPHPLooseComparisonWithTrue, + boolFromPHPLooseComparisonWithTrueNullable, + boolFromReducedLooseCoercionSafe, + boolFromReducedLooseCoercion, + boolFromReducedLooseCoercionNullableSafe, + boolFromReducedLooseCoercionNullable, + boolFromESBooleanCoercionRules, + boolFromPerlBooleanCoercionRules, + boolFromPythonBooleanCoercionRules, + boolFromLuaBooleanCoercionRules +) where + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as BS +import Data.PHPSession.Types + +-- | Returns the value of a boolean value as a 'Bool', or returns False as the default +-- 'Bool' value if the 'PHPSessionValue' is not a boolean type. This function is +-- similar to the \"strict comparison\" operator against the boolean @/TRUE/@ value. +-- +boolDefaultFalseFrom :: PHPSessionValue -> Bool +boolDefaultFalseFrom var = + case var of + PHPSessionValueBool b -> b + _ -> False + +-- | Returns the value of a boolean value as a 'Bool', or returns True as the default +-- 'Bool' value if the 'PHPSessionValue' is not a boolean type. +-- +boolDefaultTrueFrom :: PHPSessionValue -> Bool +boolDefaultTrueFrom var = + case var of + PHPSessionValueBool b -> b + _ -> True + +-- | Coerces a 'PHPSessionValue' to a 'Bool' based on PHP's conversion rules to +-- convert arbitrary values to boolean for evaluation. This function's behaviour +-- is also reminiscent of PHP's \"loose comparison\" operator against boolean +-- @/TRUE/@. +-- +-- +-- Values that result in 'True' are @/TRUE/@, non-zero numbers, non-empty strings +-- other than \"0\", objects, and non-empty arrays. +-- +-- A conversion documented in the PHP manual involving @SimpleXML@ objects that +-- coerce to @/FALSE/@ instead of @/TRUE/@ when created with empty tags is not +-- implemented by this function, as SimpleXML objects cannot be serialized directly +-- and so don't have a valid serializable form to convert from in any case. +-- +-- Because of the range of valid values of the \"loose comparison\" operator, this +-- function and variations based on other dynamically typed languages is provided +-- mainly for circumstances where they may be the best fit to map particular data +-- values to a boolean truth value system. 'boolFromReducedLooseCoercionSafe' +-- provides a significantly reduced subset of valid values to coerce from for the +-- purpose of determining a \"confirmation\" value, as opposed to simply determining +-- if a value exists or not. +-- +boolFromPHPLooseComparisonWithTrue :: PHPSessionValue -> Bool +boolFromPHPLooseComparisonWithTrue var = + case var of + PHPSessionValueBool b -> b + PHPSessionValueArray arr -> + case arr of + [] -> False + _ -> True + PHPSessionValueFloat (Left i) -> (i /= 0) + PHPSessionValueFloat (Right f) -> (f /= 0.0) + PHPSessionValueInt i -> (i /= 0) + PHPSessionValueNull -> False + PHPSessionValueString str -> + case str of + "" -> False + "0" -> False + _ -> True + PHPSessionValueObject _ _ -> True + PHPSessionValueObjectSerializeable _ _ -> True + PHPSessionValueMisc _ _ -> True + +-- | A version of 'boolFromPHPLooseComparisonWithTrue' where @/NULL/@ returns 'Nothing' +-- and all other inputs returns 'Just' with the boolean result. +boolFromPHPLooseComparisonWithTrueNullable :: PHPSessionValue -> Maybe Bool +boolFromPHPLooseComparisonWithTrueNullable var = + case var of + PHPSessionValueNull -> Nothing + _ | var /= PHPSessionValueNull -> + Just $ boolFromPHPLooseComparisonWithTrue var + + +-- | Coerces a 'PHPSessionValue' to a 'Bool' through a reduced subset of valid values. +-- 'boolFromReducedLooseCoercionSafe' and 'boolFromReducedLooseCoercion' are +-- functions intended for testing a variable for a boolean \"confirmation\" from a +-- limited number of probable representations. +-- +-- Values that result in 'True' are @/TRUE/@, non-zero numbers, \"1\" and \"-1\". +-- +-- Values that result in 'False' are @/FALSE/@, zero numbers, @/NULL/@, \"0\" and \"\". +-- +-- Values such as arrays, objects and arbitrary strings, are invalid with this +-- function and return an error. In the case of 'boolFromReducedLooseCoercionSafe' +-- this returns a 'Left' with the error message. +-- +boolFromReducedLooseCoercionSafe :: PHPSessionValue -> Either String Bool +boolFromReducedLooseCoercionSafe var = + case var of + PHPSessionValueArray _ -> mismatchError var "Bool" + PHPSessionValueBool b -> Right b + PHPSessionValueFloat (Left i) -> Right (i /= 0) + PHPSessionValueFloat (Right f) -> Right (f /= 0) + PHPSessionValueInt i -> Right (i /= 0) + PHPSessionValueNull -> Right False + PHPSessionValueObject _ _ -> mismatchError var "Bool" + PHPSessionValueObjectSerializeable _ _ -> mismatchError var "Bool" + PHPSessionValueString str -> + case str of + "1" -> Right True + "-1" -> Right True + "0" -> Right False + "" -> Right False + _ -> mismatchError var "Bool" + PHPSessionValueMisc _ _ -> mismatchError var "Bool" + +mismatchError v totype = + Left $ "Type mismatch converting from (" ++ show v ++ ") to " ++ totype + + +-- | A version of 'boolFromReducedLooseCoercionSafe' that may throw exceptions. +-- +boolFromReducedLooseCoercion :: PHPSessionValue -> Bool +boolFromReducedLooseCoercion var = + case boolFromReducedLooseCoercionSafe var of + Left message -> error message + Right var' -> var' + +-- | A version of 'boolFromReducedLooseCoercionSafe' where @/NULL/@ returns 'Right' 'Nothing' +-- and all other inputs returns 'Right' 'Just' with the boolean result. May return 'Left' +-- with an error message if given invalid values. +-- +boolFromReducedLooseCoercionNullableSafe :: PHPSessionValue -> Either String (Maybe Bool) +boolFromReducedLooseCoercionNullableSafe var = + case var of + PHPSessionValueNull -> Right Nothing + _ | var /= PHPSessionValueNull -> + case boolFromReducedLooseCoercionSafe var of + Left message -> Left message + Right result -> Right (Just result) + +-- | A version of 'boolFromReducedLooseCoercion' where @/NULL/@ returns 'Nothing' +-- and all other inputs returns 'Just' with the boolean result. May throw an +-- exception on invalid values. +-- +boolFromReducedLooseCoercionNullable :: PHPSessionValue -> Maybe Bool +boolFromReducedLooseCoercionNullable var = + case var of + PHPSessionValueNull -> Nothing + _ | var /= PHPSessionValueNull -> + Just $ boolFromReducedLooseCoercion var + + +-- | Alternative boolean coercion based on the JS/ES boolean conversion rules. +-- A particular distinction of the coercion behaviour of this function compared +-- to the behaviour of other functions is that floating point NaN returns +-- 'False' instead of 'True'. Values that return 'False' are @/NAN/@, 0, +-- the empty string \"\", @/NULL/@ and @/FALSE/@ +-- +-- PHP objects, arrays and objects implementing Serializable always return 'True'. +-- +-- JS/ES's boolean conversion is described in section 9.2 of the ECMA 262 standard. +-- +boolFromESBooleanCoercionRules :: PHPSessionValue -> Bool +boolFromESBooleanCoercionRules var = + case var of + PHPSessionValueArray arr -> True + PHPSessionValueBool b -> b + PHPSessionValueFloat (Left i) -> i /= 0 + PHPSessionValueFloat (Right f) -> + case f of + 0 -> False + _ | isNaN f -> False + _ -> True + PHPSessionValueInt i -> i /= 0 + PHPSessionValueNull -> False + PHPSessionValueObject _ arr -> True + PHPSessionValueObjectSerializeable _ bstr -> True + PHPSessionValueString str -> + case str of + "" -> False + _ -> True + PHPSessionValueMisc _ _ -> True + +-- | Alternative boolean coercion based on non-overloaded Perl 5 rules. +-- Values that return 'False' are the empty string \"\", the string containing +-- \"0\", 0, @/NULL/@ and @/FALSE/@. +-- +-- PHP objects, arrays and objects implementing Serializable always return 'True'. +-- +-- Perl's boolean coercion rules are described in the section \"Truth and Falsehood\" +-- of \"perlsyn\". +-- +-- +boolFromPerlBooleanCoercionRules :: PHPSessionValue -> Bool +boolFromPerlBooleanCoercionRules var = + case var of + PHPSessionValueArray arr -> True + PHPSessionValueBool b -> b + PHPSessionValueFloat (Left i) -> i /= 0 + PHPSessionValueFloat (Right f) -> f /= 0 + PHPSessionValueInt i -> i /= 0 + PHPSessionValueNull -> False + PHPSessionValueObject _ arr -> True + PHPSessionValueObjectSerializeable _ bstr -> True + PHPSessionValueString str -> + case str of + "0" -> False + "" -> False + _ -> True + PHPSessionValueMisc _ _ -> True + +-- | Alternative boolean coercion based on non-overloaded Python rules. +-- Values that return 'False' are the empty array @/[]/@, the empty string +-- \"\", 0, @/NULL/@ and @/FALSE/@. +-- +-- PHP objects and objects implementing Serializable always return 'True'. +-- +-- Python's boolean conversion rules are described in \"Truth Value Testing\" +-- in section 3.1 of Python 2.5's Library Reference. +-- +-- +boolFromPythonBooleanCoercionRules :: PHPSessionValue -> Bool +boolFromPythonBooleanCoercionRules var = + case var of + PHPSessionValueArray arr -> + case arr of + [] -> False + _ -> True + PHPSessionValueBool b -> b + PHPSessionValueFloat (Left i) -> i /= 0 + PHPSessionValueFloat (Right f) -> f /= 0 + PHPSessionValueInt i -> i /= 0 + PHPSessionValueNull -> False + PHPSessionValueObject _ arr -> True + PHPSessionValueObjectSerializeable _ bstr -> True + PHPSessionValueString str -> + case str of + "" -> False + _ -> True + PHPSessionValueMisc _ _ -> True + +-- | Alternative boolean coercion based on Lua rules, all values are 'True' except +-- @/NULL/@ and @/FALSE/@. +-- +-- For Lua's conversion rules, refer to the passage in section 2.4.4 \"Control +-- Structures\" of Lua 5.1's Manual. +-- +-- +boolFromLuaBooleanCoercionRules :: PHPSessionValue -> Bool +boolFromLuaBooleanCoercionRules var = + case var of + PHPSessionValueArray _ -> True + PHPSessionValueBool b -> b + PHPSessionValueFloat _ -> True + PHPSessionValueInt i -> True + PHPSessionValueNull -> False + PHPSessionValueObject _ _ -> True + PHPSessionValueObjectSerializeable _ _ -> True + PHPSessionValueString str -> True + PHPSessionValueMisc _ _ -> True + + diff --git a/Data/PHPSession/ImplicitConv/PHPTypeCoercion.hs b/Data/PHPSession/ImplicitConv/PHPTypeCoercion.hs new file mode 100644 --- /dev/null +++ b/Data/PHPSession/ImplicitConv/PHPTypeCoercion.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} +-- | +-- Module : Data.PHPSession.ImplicitConv.PHPTypeCoercion +-- Copyright: (c) 2014 Edward Blake +-- License: BSD-style +-- Maintainer: Edward L. Blake +-- Stability: experimental +-- Portability: portable +-- +-- Functions for performing conversion from 'PHPSessionValue' objects to Haskell +-- types while using a subset of the implicit PHP type coercion behaviour. Some +-- of the differences from the implicit type conversion found in PHP are noted: +-- +-- * Conversions that are documented as undefined behaviour in the PHP manual +-- will throw definite exceptions with these functions. +-- +-- * A significant difference from PHP's conversion rules is that @/NULL/@ +-- cannot be directly converted to any data type except to 'Bool', otherwise +-- @/NULL/@ has to be handled by using the type @'Maybe' a@ to capture +-- nullable values. +-- +-- * Objects that implement Serializable are not convertible to any other type +-- at all as their value systems are not directly interpretable in a meaningful +-- manner. +-- +-- * Numbers can be converted to strings, but only strings that satisfy +-- @reads str = [(value, \"\")]@ can be converted back to numbers. +-- +-- * Arrays and objects to string conversions which would normally be coerced +-- to the simple strings \"Array\" and \"Object\" in PHP, are simply considered +-- errors with these conversion functions. +-- +module Data.PHPSession.ImplicitConv.PHPTypeCoercion ( + -- * Convert from 'PHPSessionValue' + convFromPHPImplicit, + convFromPHPImplicitSafe, + -- * Type classes + ConversionFromPHPImplicitValueOrMismatch(..) +) where + +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.ByteString.Char8 as BS +import Data.PHPSession.Types +import Data.PHPSession.ImplicitConv.ConvBool +import Data.Int (Int32, Int64) +import Data.List as L (foldl') +import Data.PHPSession.Conv + +class ConversionFromPHPImplicitValueOrMismatch b where + convFromPHPImplicitOM :: PHPSessionValue -> Either String b + + +isScalarForArray v = + case v of + PHPSessionValueBool _ -> True + PHPSessionValueFloat _ -> True + PHPSessionValueInt _ -> True + PHPSessionValueString _ -> True + PHPSessionValueNull -> False + PHPSessionValueObjectSerializeable _ _ -> False + PHPSessionValueMisc _ _ -> False + PHPSessionValueObject _ _ -> False + PHPSessionValueArray _ -> False + +-- +-- Refer to the following reference on array conversion at: +-- +-- +instance ConversionFromPHPImplicitValueOrMismatch [(PHPSessionValue,PHPSessionValue)] where + -- Not converted to array: + -- * PHPSessionValueNull (differs from PHP: PHP creates empty array) + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM v | isScalarForArray v = arrayScalarAsValue v + convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = Right arr + convFromPHPImplicitOM (PHPSessionValueArray arr) = Right arr + convFromPHPImplicitOM v = mismatchError v "[(PHPSessionValue,PHPSessionValue)]" + + +arrayScalarAsValue :: PHPSessionValue -> Either String [(PHPSessionValue,PHPSessionValue)] +arrayScalarAsValue r = + Right ([(PHPSessionValueInt 0, r)]) + +convArrayScalarLeftSide :: ConversionFromPHPImplicitValueOrMismatch a => PHPSessionValue -> Either String [(a,PHPSessionValue)] +convArrayScalarLeftSide r = + case convFromPHPImplicitOM (PHPSessionValueInt 0) of + Left message -> Left message + Right index -> + Right ([(index, r)]) + +convArrayListLeftSide :: ConversionFromPHPImplicitValueOrMismatch a => [(PHPSessionValue,PHPSessionValue)] -> Either String [(a,PHPSessionValue)] +convArrayListLeftSide vars = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + let l' = convFromPHPImplicitOM l + in case l' of + Left errl -> Left errl + Right l'' -> + Right ((l'',r) : lst) + +instance ConversionFromPHPImplicitValueOrMismatch b => ConversionFromPHPImplicitValueOrMismatch [(PHPSessionValue,b)] where + -- Not converted to array: + -- * PHPSessionValueNull (differs from PHP: PHP creates empty array) + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM v | isScalarForArray v = convArrayScalarRightSide v convFromPHPImplicitOM + convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = convArrayListRightSide arr convFromPHPImplicitOM + convFromPHPImplicitOM (PHPSessionValueArray arr) = convArrayListRightSide arr convFromPHPImplicitOM + convFromPHPImplicitOM v = mismatchError v "ConversionFromPHPValueOrMismatch b => ConversionFromPHPValueOrMismatch [(PHPSessionValue,b)]" + + +-- convArrayScalarRightSide :: ConversionFromPHPImplicitValueOrMismatch b => PHPSessionValue -> Either String [(PHPSessionValue,b)] +convArrayScalarRightSide r conv = + case conv r of + Left message -> Left message + Right r' -> Right ([(PHPSessionValueInt 0, r')]) + +-- convArrayListRightSide :: ConversionFromPHPImplicitValueOrMismatch b => [(PHPSessionValue,PHPSessionValue)] -> Either String [(PHPSessionValue,b)] +convArrayListRightSide vars conv = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + case conv r of + Left errr -> Left errr + Right r'' -> + Right $ (l,r'') : lst + + +instance (ConversionFromPHPImplicitValueOrMismatch a, ConversionFromPHPImplicitValueOrMismatch b) => ConversionFromPHPImplicitValueOrMismatch [(a,b)] where + -- Not converted to array: + -- * PHPSessionValueNull (differs from PHP: PHP creates empty array) + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM v | isScalarForArray v = convArrayScalarBothSides v convFromPHPImplicitOM + convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = convArrayListBothSides arr convFromPHPImplicitOM + convFromPHPImplicitOM (PHPSessionValueArray arr) = convArrayListBothSides arr convFromPHPImplicitOM + convFromPHPImplicitOM v = mismatchError v "(ConversionFromPHPValueOrMismatch a, ConversionFromPHPValueOrMismatch b) => ConversionFromPHPValueOrMismatch [(a,b)]" + + +convArrayScalarBothSides + :: ConversionFromPHPImplicitValueOrMismatch t1 => + t -> (t -> Either String t2) -> Either String [(t1, t2)] +convArrayScalarBothSides r conv = + case convFromPHPImplicitOM (PHPSessionValueInt 0) of + Left message -> Left message + Right index -> + case conv r of + Left message' -> Left message' + Right r' -> Right ([(index, r')]) + +-- convArrayListBothSides :: (ConversionFromPHPImplicitValueOrMismatch a, ConversionFromPHPImplicitValueOrMismatch b) => [(PHPSessionValue,PHPSessionValue)] -> Either String [(a,b)] +convArrayListBothSides vars conv = + case L.foldl' ontoTuple (Right []) vars of + Left str -> Left str + Right lst -> Right $ reverse lst + where + ontoTuple (Left str) _ = Left str + ontoTuple (Right lst) (l,r) = + case convFromPHPImplicitOM l of + Left errl -> Left errl + Right l'' -> + case conv r of + Left errr -> Left errr + Right r'' -> + Right ((l'',r'') : lst) + +{- +-- Sequenceable: +instance ConversionFromPHPImplicitValueOrMismatch [PHPSessionValue] where + -- Not converted to array: + -- * PHPSessionValueNull (differs from PHP: PHP creates empty array) + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM v | isScalarForArray v = Right [v] + convFromPHPImplicitOM (PHPSessionValueObject _cls arr) = Right $ map (\(_,a) -> a) arr + convFromPHPImplicitOM (PHPSessionValueArray arr) = Right $ map (\(_,a) -> a) arr + convFromPHPImplicitOM v = mismatchError v "[PHPSessionValue]" +-} + +-- Refer to Data.PHPSession.ImplicitConv.ConvBool for the boolean implicit +-- conversion. +-- +instance ConversionFromPHPImplicitValueOrMismatch Bool where + convFromPHPImplicitOM var = + Right $ boolFromPHPLooseComparisonWithTrue var + +-- Refer to the following reference for floating point conversion rules at +-- +-- +instance ConversionFromPHPImplicitValueOrMismatch Double where + convFromPHPImplicitOM (PHPSessionValueFloat (Right var)) = (Right) var + convFromPHPImplicitOM (PHPSessionValueFloat (Left var)) = (Right . fromIntegral) var + convFromPHPImplicitOM (PHPSessionValueString str) = + case reads str' of + [(val,"")] -> Right val + [] -> let v = PHPSessionValueString str + in mismatchError v "Double" + where + str' = LBS.unpack str + convFromPHPImplicitOM var = + let intvar = convFromPHPImplicitOM var :: Either String Int + in case intvar of + Left message -> Left message + Right intvar' -> + (Right . fromIntegral) intvar' + + +-- Refer to the following reference for integer conversion rules: +-- +-- +instance ConversionFromPHPImplicitValueOrMismatch Int where + -- Not converted to Int: + -- * PHPSessionValueArray + -- * PHPSessionValueObject + -- * PHPSessionValueNull + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM (PHPSessionValueBool b) = Right $ if b then 1 else 0 + convFromPHPImplicitOM (PHPSessionValueFloat lr) = + Right $ case lr of + Left i -> i + Right f -> floor f + convFromPHPImplicitOM (PHPSessionValueInt val) = Right $ fromIntegral val + convFromPHPImplicitOM (PHPSessionValueString str) = + case reads str' of + [(val,"")] -> Right $ fromIntegral val + [] -> + case reads str' of + [(valdbl,"")] -> Right $ floor valdbl + [] -> let v = PHPSessionValueString str + in mismatchError v "Int" + where str' = LBS.unpack str + convFromPHPImplicitOM v = mismatchError v "Int" +instance ConversionFromPHPImplicitValueOrMismatch Int32 where + convFromPHPImplicitOM var = + let var' = convFromPHPImplicitOM var :: Either String Int + in case var' of + Left message -> Left message + Right int -> Right $ fromIntegral int +instance ConversionFromPHPImplicitValueOrMismatch Int64 where + convFromPHPImplicitOM var = + let var' = convFromPHPImplicitOM var :: Either String Int + in case var' of + Left message -> Left message + Right int -> Right $ fromIntegral int + + +instance ConversionFromPHPImplicitValueOrMismatch (PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)]) where + -- Not converted to Object: + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueMisc + convFromPHPImplicitOM (PHPSessionValueArray arr) = Right (phpStdClass,arr) + convFromPHPImplicitOM (PHPSessionValueBool b) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueBool b)]) + convFromPHPImplicitOM (PHPSessionValueFloat a) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueFloat a)]) + convFromPHPImplicitOM (PHPSessionValueInt i) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueInt i)]) + convFromPHPImplicitOM (PHPSessionValueNull) = Right (phpStdClass,[]) + convFromPHPImplicitOM (PHPSessionValueObject cls arr) = Right (cls,arr) + convFromPHPImplicitOM (PHPSessionValueString a) = Right (phpStdClass,[(phpScalarMember, PHPSessionValueString a)]) + convFromPHPImplicitOM v = mismatchError v "(PHPSessionClassName, [(PHPSessionValue,PHPSessionValue)])" + +phpStdClass = PHPSessionClassName "stdClass" +phpScalarMember = PHPSessionValueString "scalar" + +instance ConversionFromPHPImplicitValueOrMismatch (PHPSessionClassName, LBS.ByteString) where + -- Not converted to (and from) objects implementing Serializable: + -- * PHPSessionValueArray + -- * PHPSessionValueBool + -- * PHPSessionValueFloat, + -- * PHPSessionValueInt + -- * PHPSessionValueNull + -- * PHPSessionValueObject + -- * PHPSessionValueString, + -- * PHPSessionValueMisc + convFromPHPImplicitOM (PHPSessionValueObjectSerializeable cls arr) = Right (cls,arr) + convFromPHPImplicitOM v = mismatchError v "(PHPSessionClassName, LBS.ByteString)" + +-- +-- +instance ConversionFromPHPImplicitValueOrMismatch LBS.ByteString where + -- Not converted to string: + -- * PHPSessionValueArray + -- * PHPSessionValueObject + -- * PHPSessionValueObjectSerializeable + -- * PHPSessionValueNull (differs from PHP: PHP creates empty string "") + -- * PHPSessionValueMisc + convFromPHPImplicitOM (PHPSessionValueBool b) = + case b of + True -> Right "1" + False -> Right "" + convFromPHPImplicitOM (PHPSessionValueFloat a) = + case a of + Left i -> (Right . LBS.pack . show) i + Right f -> (Right . LBS.pack . show) f + convFromPHPImplicitOM (PHPSessionValueInt i) = + (Right . LBS.pack . show) i + -- Unused: convFromPHPImplicitOM (PHPSessionValueNull) = Right "" + convFromPHPImplicitOM (PHPSessionValueString var) = Right var + convFromPHPImplicitOM v = mismatchError v "ByteString" + +instance ConversionFromPHPImplicitValueOrMismatch BS.ByteString where + convFromPHPImplicitOM var = + let var' = convFromPHPImplicitOM var :: Either String LBS.ByteString + in case var' of + Left message -> Left message + Right str -> Right (BS.concat $ LBS.toChunks str) + +instance ConversionFromPHPImplicitValueOrMismatch a => ConversionFromPHPImplicitValueOrMismatch (Maybe a) where + convFromPHPImplicitOM PHPSessionValueNull = Right Nothing + convFromPHPImplicitOM v = + case convFromPHPImplicitOM v of + Left s -> Left s + Right b' -> Right (Just b') + + +mismatchError v totype = + Left $ "Type mismatch converting from (" ++ show v ++ ") to " ++ totype + +-- | 'convFromPHPImplicit' and 'convFromPHPImplicitSafe' are functions that convert +-- values stored as 'PHPSessionValue' into appropriate Haskell types depending on +-- the desired type cast or inferred. Unlike the 'convFrom' and 'convFromSafe' +-- functions provided in "Data.PHPSession.Conv", functions provided in this module +-- perform type coercion based on a significant number of conversion rules to +-- satisfy the type cast or inferred. +-- +-- The example @arrayOfPHPStrings@ definition given in the example documented in +-- "Data.PHPSession.Conv" can be evaluated to @[(0,\"Hello\"),(1,\"World\")]@. +-- +-- >>> convFromPHPImplicit arrayOfPHPStrings :: [(Int,LBS.ByteString)] +-- [(0,"Hello"),(1,"World")] +-- +-- However, if the desired type signature is changed: +-- +-- >>> convFromPHPImplicit arrayOfPHPStrings :: [(LBS.ByteString,LBS.ByteString)] +-- [("0","Hello"),("1","World")] +-- +-- Where there is the possibility that the value being sought may be @/NULL/@, the +-- type should be @('Maybe' a)@. +-- +convFromPHPImplicit :: ConversionFromPHPImplicitValueOrMismatch b => PHPSessionValue -> b +convFromPHPImplicit var = + case convFromPHPImplicitOM var of + Left message -> error message + Right var' -> var' + +-- | 'convFromPHPImplicitSafe' is a version of 'convFromPHPImplicit' that returns a +-- 'Left' with an error message instead of throwing a run time exception. +-- +convFromPHPImplicitSafe + :: ConversionFromPHPImplicitValueOrMismatch b => + PHPSessionValue -> Either String b +convFromPHPImplicitSafe var = convFromPHPImplicitOM var diff --git a/hs-php-session.cabal b/hs-php-session.cabal --- a/hs-php-session.cabal +++ b/hs-php-session.cabal @@ -1,5 +1,5 @@ name: hs-php-session -version: 0.0.9.2 +version: 0.0.9.3 synopsis: PHP session and values serialization description: A library for encoding and decoding serialized PHP sessions in the format @@ -24,6 +24,9 @@ exposed-modules: Data.PHPSession Data.PHPSession.Types + Data.PHPSession.Conv + Data.PHPSession.ImplicitConv.ConvBool + Data.PHPSession.ImplicitConv.PHPTypeCoercion -- other-modules: build-depends: base == 4.*,