diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,6 @@ +# Changelog for typed-encoding-encoding + +## Unreleased changes + +## 0.1.0.0 +Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2020 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# typed-encoding-encoding + +A thin overlay over `encoding` package to add `type-encoding` type safety. + +https://hackage.haskell.org/package/encoding +https://hackage.haskell.org/package/typed-encoding + 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/doctest/Spec.hs b/doctest/Spec.hs new file mode 100644 --- /dev/null +++ b/doctest/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-discover #-} diff --git a/src/Data/TypedEncoding/Pkg/Encoding.hs b/src/Data/TypedEncoding/Pkg/Encoding.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Pkg/Encoding.hs @@ -0,0 +1,39 @@ + +-- | This package is a thin layer over the /encoding/ package to create types compatible +-- with /type-encoding/. +-- +-- == Naming conventions +-- +-- @ +-- "enc-pkg/encoding:[encoding]" +-- @ +-- +-- where @"[encoding]"@ is String name used by the 'Encoding.DynEncoding' in the /encoding/ package. +-- +-- Example: @"enc-pkg/encoding:cyrillic"@ +-- +-- == Warnings / AS-IS type wrapping +-- +-- The /encoding/ package can exhibit behavior that may not map well to +-- type level guarantees that /typed-encoding/ tries to enforce, examples of this are documented in +-- +-- "Data.TypedEncoding.Pkg.Encoding.Conv" +-- +-- In particular, it seems not possible to implement +-- 'Data.TypedEncoding.Common.Class.Validate.Validate' instance with a decent performance. +-- +-- For this reason module defining it is annotated with WARNING pragma and is kept separate: +-- +-- "Data.TypedEncoding.Pkg.Encoding.Warn.Instances" (/typed-encoding/ Validate instance for String encodings) + + +module Data.TypedEncoding.Pkg.Encoding ( + -- * Type safe versions of encode and decode functions from /encoding/ package + module Data.TypedEncoding.Pkg.Encoding.Conv + + -- * /typed-encoding/ class instances for /Encode/, /Decode/, /ToEncString/, and /FromEncString/ + , module Data.TypedEncoding.Pkg.Encoding.Instances + ) where + +import Data.TypedEncoding.Pkg.Encoding.Conv +import Data.TypedEncoding.Pkg.Encoding.Instances diff --git a/src/Data/TypedEncoding/Pkg/Encoding/Conv.hs b/src/Data/TypedEncoding/Pkg/Encoding/Conv.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Pkg/Encoding/Conv.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Contains type save equivalents of the following functions defined in /encoding/: +-- +-- * 'Encoding.encodeStrictByteStringExplicit' +-- * 'Encoding.encodeLazyByteStringExplicit' +-- * 'Encoding.encString' +-- * 'Encoding.decodeStrictByteStringExplicit' +-- * 'Encoding.decodeLazyByteStringExplicit' +-- * 'Encoding.decodeStringExplicit' +-- +-- +-- == Warnings +-- +-- These conversions are provides AS-IS and assume that /encoding/ functions behave +-- in a way consistent with /typed-encoding/ type definitions. +-- +-- For example, /typed-encoding/ effectively guarantees that decode function will never fail +-- and it is safe to use @Identity@ instance of the @UnexpectedDecodeErr@ class. +-- +-- In /encoding v0.8.5/, the decoding can fail after the encoding succeeded: +-- +-- >>> Encoding.encodeStringExplicit EncCP932.CP932 "\DEL" +-- Right "\DEL" +-- >>> Encoding.decodeStringExplicit EncCP932.CP932 "\DEL" +-- Left (IllegalCharacter 127) +-- +-- Here are some other peculiarities: +-- +-- /cp1257/ is a single bit encoding and one could expect this to fail, but it succeeds: +-- +-- >>> Encoding.encodeStringExplicit (Encoding.encodingFromString "cp1257") "\x100" +-- Right "\194" +-- +-- Decoding can also be surprising: +-- +-- >>> Encoding.decodeStringExplicit EncASCII.ASCII "\236\239" +-- Right "\236\239" +-- +-- here is UTF8 decoding +-- +-- >>> Encoding.decodeStringExplicit EncUTF8.UTF8 "\192\NUL" +-- Right "\NUL" +-- >>> Encoding.encodeStringExplicit EncUTF8.UTF8 "\NUL" +-- Right "\NUL" +-- +-- This package does not try to fix these issues, only provides a wrapper +-- that annotates encodings as symbols. + + +module Data.TypedEncoding.Pkg.Encoding.Conv where + +import qualified Data.TypedEncoding.Instances.Support as Typed + +import qualified Data.Encoding as Encoding + +import GHC.TypeLits +import Data.Proxy +import qualified Data.List as L +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + + +-- $setup +-- >>> :set -XOverloadedStrings -XDataKinds -XTypeApplications -XFlexibleContexts +-- >>> import Data.Functor.Identity +-- >>> import qualified Data.TypedEncoding as Usage +-- >>> import Data.Encoding.ASCII as EncASCII +-- >>> import Data.Encoding.UTF8 as EncUTF8 +-- >>> import Data.Encoding.CP932 as EncCP932 + +type family IsDynEnc (s :: Symbol) :: Bool where + IsDynEnc s = Typed.AcceptEq ('Text "Not encoding restriction " ':<>: ShowType s ) (CmpSymbol (Typed.TakeUntil s ":") "enc-pkg/encoding") + +type DynEnc s = (KnownSymbol s, IsDynEnc s ~ 'True) + + + +-- * Conversion To ByteString + +-- | +-- @encodeStrictByteStringExplicit@ creates values of types like +-- +-- @ +-- Enc '["enc-pkg/encoding:cyrillic"] () ByteString +-- @ +-- +-- >>> fmap Typed.displ . encodeStrictByteStringExplicit @"enc-pkg/encoding:cyrillic" . Typed.toEncoding () $ "а на животе кнопка" +-- Right "Enc '[enc-pkg/encoding:cyrillic] () (ByteString \208 \221\208 \214\216\210\222\226\213 \218\221\222\223\218\208)" +-- +-- >>> fmap Typed.displ . encodeStrictByteStringExplicit @"enc-pkg/encoding:koi8_r" . Typed.toEncoding () $ "а на животе кнопка" +-- Right "Enc '[enc-pkg/encoding:koi8_r] () (ByteString \193 \206\193 \214\201\215\207\212\197 \203\206\207\208\203\193)" +-- +-- >>> "а на животе кнопка" +-- "\1072 \1085\1072 \1078\1080\1074\1086\1090\1077 \1082\1085\1086\1087\1082\1072" +-- +-- >>> "Статья" +-- "\1057\1090\1072\1090\1100\1103" +-- +-- >>> fmap Typed.displ . encodeStrictByteStringExplicit @"enc-pkg/encoding:cyrillic" . Typed.toEncoding () $ "Статья" +-- Right "Enc '[enc-pkg/encoding:cyrillic] () (ByteString \193\226\208\226\236\239)" +-- +-- >>> encodeStrictByteStringExplicit @"enc-pkg/encoding:ascii" . Typed.toEncoding () $ "Статья" +-- Left (EncodeEx "enc-pkg/encoding:ascii" (HasNoRepresentation '\1057')) +-- +-- >>> fmap Typed.displ . encodeStrictByteStringExplicit @"enc-pkg/encoding:ascii" . Typed.toEncoding () $ "story" +-- Right "Enc '[enc-pkg/encoding:ascii] () (ByteString story)" +encodeStrictByteStringExplicit :: forall s xs c . + ( + DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc xs c String -> Either Typed.EncodeEx (Typed.Enc (s ': xs) c B.ByteString) +encodeStrictByteStringExplicit s = + do + enc <- Typed.asEncodeEx p . exferDynEncoding $ p + Typed.withUnsafeCoerceF (Typed.asEncodeEx p . Encoding.encodeStrictByteStringExplicit enc) s + where + p = Proxy :: Proxy s + + +-- | +-- Converts 'String' to some @Enc '["enc-pkg/encoding:..."] () BL.ByteString@ type +-- by actually encoding characters in the String into correct byte layout. +encodeLazyByteStringExplicit :: forall s xs c . + ( + DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc xs c String -> Either Typed.EncodeEx (Typed.Enc (s ': xs) c BL.ByteString) +encodeLazyByteStringExplicit s = + do + enc <- Typed.asEncodeEx p $ exferDynEncoding p + Typed.withUnsafeCoerceF (Typed.asEncodeEx p . Encoding.encodeLazyByteStringExplicit enc) s + where + p = Proxy :: Proxy s + +-- * Conversion to encoded String + +-- | +-- Converts 'String' to some @Enc '["enc-pkg/encoding:..."] () String@ type +-- by actually encoding characters in the String into a certain byte layout. +-- +-- The resulting payload has all Characters representing bytes, that is @< \'\\255\'@ +encodeStringExplicit :: forall s xs c . + ( + DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc xs c String -> Either Typed.EncodeEx (Typed.Enc (s ': xs) c String) +encodeStringExplicit s = + do + enc <- Typed.asEncodeEx p $ exferDynEncoding p + Typed.withUnsafeCoerceF (Typed.asEncodeEx p . Encoding.encodeStringExplicit enc) s + where + p = Proxy :: Proxy s + + + +encString :: forall s xs c . + ( + DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Encoding (Either Typed.EncodeEx) s "enc-pkg/encoding" c String +encString = Typed._mkEncoding encodeStringExplicit + + + +-- * Conversion From ByteString + +-- | +-- +-- >>> fmap Typed.displ $ decodeStrictByteStringExplicit @"enc-pkg/encoding:cyrillic" @'[] @Identity (Typed.unsafeSetPayload () "\193\226\208\226\236\239") +-- Identity "Enc '[] () (String \1057\1090\1072\1090\1100\1103)" +decodeStrictByteStringExplicit :: forall s xs f c . + (Typed.UnexpectedDecodeErr f + , Monad f + , DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc (s ': xs) c B.ByteString -> f (Typed.Enc xs c String) +decodeStrictByteStringExplicit x = + do + enc <- Typed.asUnexpected @s . exferDynEncoding $ p + Typed.withUnsafeCoerceF (Typed.asUnexpected @s . Encoding.decodeStrictByteStringExplicit enc) x + where p = Proxy :: Proxy s + + +decodeLazyByteStringExplicit :: forall s xs f c . + (Typed.UnexpectedDecodeErr f + , Monad f + , DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc (s ': xs) c BL.ByteString -> f (Typed.Enc xs c String) +decodeLazyByteStringExplicit x = + do + enc <- Typed.asUnexpected @s . exferDynEncoding $ p + Typed.withUnsafeCoerceF (Typed.asUnexpected @s . Encoding.decodeLazyByteStringExplicit enc) x + where p = Proxy :: Proxy s + + +-- * Conversion From encoded String + +decodeStringExplicit :: forall s xs f c . + (Typed.UnexpectedDecodeErr f + , Monad f + , DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Enc (s ': xs) c String -> f (Typed.Enc xs c String) +decodeStringExplicit x = + do + enc <- Typed.asUnexpected @s . exferDynEncoding $ p + Typed.withUnsafeCoerceF (Typed.asUnexpected @s . Encoding.decodeStringExplicit enc) x + where p = Proxy :: Proxy s + +decString :: forall s xs f c . + (Typed.UnexpectedDecodeErr f + , Monad f + , DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Decoding f s "enc-pkg/encoding" c String + +decString = Typed.mkDecoding decodeStringExplicit + + + +-- * Helpers +-- | Provides type safety over existence of 'Encoding.DynEncoding' +getDynEncoding :: forall s xs c str. (DynEnc s) => Typed.Enc (s ': xs) c str -> Encoding.DynEncoding +getDynEncoding _ = Encoding.encodingFromString nm + where + p = Proxy :: Proxy s + nm = L.drop 8 . symbolVal $ p + +-- * Implementation + +exferDynEncoding :: (KnownSymbol s, DynEnc s) => Proxy s -> Either String Encoding.DynEncoding +exferDynEncoding p = explainMaybe ("Invalid encoding " ++ nm) . Encoding.encodingFromStringExplicit $ nm + where + nm = L.drop 17 . symbolVal $ p + explainMaybe _ (Just x) = Right x + explainMaybe msg Nothing = Left msg + diff --git a/src/Data/TypedEncoding/Pkg/Encoding/Instances.hs b/src/Data/TypedEncoding/Pkg/Encoding/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Pkg/Encoding/Instances.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Key instances defined here are 'Typed.ToEncString' and 'Typed.FromEncString'. +-- These allow to create encoded @ByteString@ from a String (@ToEncString@) and decode @ByteString@ back (@ToEncString@). +-- +-- The String 'Typed.Encode', 'Typed.Decode' instances is less interesting since is works with @String@ type only. +-- +-- See the /warnings/ section of +-- "Data.TypedEncoding.Pkg.Encoding.Conv" + + +module Data.TypedEncoding.Pkg.Encoding.Instances where + +import qualified Data.TypedEncoding.Instances.Support as Typed + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import qualified Data.TypedEncoding.Pkg.Encoding.Conv as Conv + +-- $setup +-- >>> :set -XOverloadedStrings -XDataKinds -XTypeApplications -XFlexibleContexts +-- >>> import Data.Functor.Identity +-- >>> import qualified Data.TypedEncoding as Usage + + +-- | +-- +-- >>> :{ +-- Usage.displ +-- <$> Usage.toEncStringF' +-- @"enc-pkg/encoding" +-- @"enc-pkg/encoding:cyrillic" +-- @(Either Usage.EncodeEx) +-- @String +-- @B.ByteString "Статья" +-- :} +-- Right "Enc '[enc-pkg/encoding:cyrillic] () (ByteString \193\226\208\226\236\239)" +instance (Conv.DynEnc s, Typed.Algorithm s "enc-pkg/encoding") => Typed.ToEncString (Either Typed.EncodeEx) s "enc-pkg/encoding" String B.ByteString where + toEncF = Conv.encodeStrictByteStringExplicit . Typed.toEncoding () + +instance (Conv.DynEnc s, Typed.Algorithm s "enc-pkg/encoding") => Typed.ToEncString (Either Typed.EncodeEx) s "enc-pkg/encoding" String BL.ByteString where + toEncF = Conv.encodeLazyByteStringExplicit . Typed.toEncoding () + +-- | +-- +-- >>> :{ +-- Usage.displ <$> +-- Usage.fromEncStringF' +-- @"enc-pkg/encoding" +-- @"enc-pkg/encoding:cyrillic" +-- @(Either Usage.UnexpectedDecodeEx) +-- @String @B.ByteString +-- (Typed.unsafeSetPayload () "\193\226\208\226\236\239") +-- :} +-- Right "(String \1057\1090\1072\1090\1100\1103)" +instance ( + Typed.UnexpectedDecodeErr f + , Monad f + , Conv.DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => Typed.FromEncString f s "enc-pkg/encoding" String B.ByteString where + fromEncF = fmap Typed.fromEncoding . Conv.decodeStrictByteStringExplicit + +instance ( + Typed.UnexpectedDecodeErr f + , Monad f + , Conv.DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => Typed.FromEncString f s "enc-pkg/encoding" String BL.ByteString where + fromEncF = fmap Typed.fromEncoding . Conv.decodeLazyByteStringExplicit + + + +instance ( + Conv.DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => Typed.Encode (Either Typed.EncodeEx) s "enc-pkg/encoding" c String where + encoding = Conv.encString + + +instance ( + Typed.UnexpectedDecodeErr f + , Monad f + , Conv.DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => Typed.Decode f s "enc-pkg/encoding" c String where + decoding = Conv.decString + +-- | All /encoding/ encodings map characters to bytes +-- This defines @EncSuperset s@ as @"r-CHAR8"@ +instance Conv.DynEnc s => Typed.EncodingSuperset s where + type EncSuperset s = "r-CHAR8" + diff --git a/src/Data/TypedEncoding/Pkg/Encoding/Warn/Instances.hs b/src/Data/TypedEncoding/Pkg/Encoding/Warn/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/TypedEncoding/Pkg/Encoding/Warn/Instances.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-- {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- There seems to be no easy ways to verify encoding using the /encoding/ package. +-- +-- /decode/ functions implemented in /encoding/ are very forgiving and work +-- on invalid encoded inputs. This forces this package to resort to checking that +-- +-- @ +-- Encoding.encodeXyz . Encoding.decodeXyz +-- @ +-- +-- acts as the identity. This is obviously quite expensive. +-- +-- This module provides such implementation and hence the warning. +-- +-- >>> Encoding.decodeStrictByteStringExplicit EncUTF8.UTF8 "\192\NUL" +-- Right "\NUL" +-- +-- >>> Encoding.encodeStrictByteStringExplicit EncUTF8.UTF8 "\NUL" +-- Right "\NUL" + + +module Data.TypedEncoding.Pkg.Encoding.Warn.Instances {-# WARNING "Not optimized for performance" #-} where + +import qualified Data.TypedEncoding.Instances.Support as Typed +import qualified Data.Encoding as Encoding + +import GHC.TypeLits +import Data.Proxy + +import Data.TypedEncoding.Pkg.Encoding.Conv + + +-- import qualified Data.TypedEncoding as Usage +-- import Data.Encoding.UTF8 as EncUTF8 + + +-- $setup +-- >>> :set -XOverloadedStrings -XDataKinds -XTypeApplications -XFlexibleContexts +-- >>> import Data.Functor.Identity +-- >>> import qualified Data.TypedEncoding as Usage +-- >>> import Data.Encoding.UTF8 as EncUTF8 + + +-- * Validation Combinators (Slow) + +data DecodeOrEncodeException = + DecErr Encoding.DecodingException + | EncErr Encoding.EncodingException + | DecEncMismatch + deriving (Show, Eq) + + +validatingDecS :: forall s c . + ( + DynEnc s + , Typed.Algorithm s "enc-pkg/encoding" + ) => + Typed.Decoding (Either Typed.UnexpectedDecodeEx) s "enc-pkg/encoding" c String +validatingDecS = Typed._implDecodingF (verifyDynDec (Proxy :: Proxy s) exferDynEncoding slowValidation) + where + -- see comments in fromDynEncB + slowValidation enc str = do + dec <- either (Left . DecErr) Right . Encoding.decodeStringExplicit enc $ str + res <- either (Left . EncErr) Right . Encoding.encodeStringExplicit enc $ dec + if str == res + then Right dec + else Left DecEncMismatch + + +-- tst = fmap Usage.displ . +-- Usage.recreateFAll' +-- @'["enc-pkg/encoding"] +-- @'["enc-pkg/encoding:cyrillic"] +-- @(Either Usage.RecreateEx) +-- @() +-- @String . Usage.toEncoding () $ "\193\226\208\226\236\239" + + +-- | +-- +-- >>> :{ +-- fmap Usage.displ . +-- Usage.recreateFAll' +-- @'["enc-pkg/encoding"] +-- @'["enc-pkg/encoding:greek"] +-- @(Either Usage.RecreateEx) +-- @() +-- @String . Usage.toEncoding () $ "\193\226\208\226\236\255" +-- :} +-- Left (RecreateEx "enc-pkg/encoding:greek" (DecErr (IllegalCharacter 255))) +-- +-- @\"Статья\"@ example: +-- +-- >>> :{ +-- fmap Usage.displ . +-- Usage.recreateFAll' +-- @'["enc-pkg/encoding"] +-- @'["enc-pkg/encoding:cyrillic"] +-- @(Either Usage.RecreateEx) +-- @() +-- @String . Usage.toEncoding () $ "\193\226\208\226\236\239" +-- :} +-- Right "Enc '[enc-pkg/encoding:cyrillic] () (String \193\226\208\226\236\239)" +instance (KnownSymbol s , DynEnc s, Typed.Algorithm s "enc-pkg/encoding", Typed.RecreateErr f, Applicative f) => Typed.Validate f s "enc-pkg/encoding" c String where + validation = Typed.validFromDec' @"enc-pkg/encoding" validatingDecS + + + +verifyDynDec :: forall s str err1 err2 enc a. (KnownSymbol s, Show err1, Show err2) => + Proxy s -- ^ proxy defining encoding annotation + -> (Proxy s -> Either err1 enc) -- ^ finds encoding marker @enc@ for given annotation or fails + -> (enc -> str -> Either err2 str) -- ^ decoder based on @enc@ marker + -> str + -> Either Typed.UnexpectedDecodeEx str +verifyDynDec p findenc decoder str = + do + enc <- either (Left . Typed.UnexpectedDecodeEx p) Right . findenc $ p + case decoder enc str of + Left err -> Left $ Typed.UnexpectedDecodeEx p err + Right r -> Right r diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,3 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +-- main :: IO () +-- main = putStrLn "Only doctest suite is implemented, no other tests" diff --git a/test/Test/SafeDecodingSpec.hs b/test/Test/SafeDecodingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/SafeDecodingSpec.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fwarn-unused-imports #-} + +-- | +module Test.SafeDecodingSpec where + + +import Data.TypedEncoding +import Data.TypedEncoding.Pkg.Encoding.Conv +import Data.TypedEncoding.Pkg.Encoding.Instances () +import Data.TypedEncoding.Pkg.Encoding.Warn.Instances () + +import Data.TypedEncoding + +import Test.QuickCheck.Instances.ByteString () +import Test.QuickCheck +import Test.QuickCheck.Property +import Test.Hspec +import GHC.TypeLits +import Data.Either + +-- | decoding should never fail if encoding succeeds +propEncDec :: forall s . (Algorithm s "enc-pkg/encoding") => + Encoding (Either EncodeEx) s "enc-pkg/encoding" () String + -> Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String + -> String + -> Property +propEncDec encf decf str = property $ liftBool (_propSafeDecoding @s encf decf () str) + + +propValidation :: forall s . (Algorithm s "enc-pkg/encoding") => + Encoding (Either EncodeEx) s "enc-pkg/encoding" () String + -> Validation (Either RecreateEx) s "enc-pkg/encoding" () String + -> Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String + -> String + -> Property +propValidation encf vf decf str = property $ liftBool (_propSafeValidatedDecoding @s vf decf () modStr) + -- bit of ugly hack, it would be much more work to control Arbitrary outside of this call + where + modStr = case str of + 'a': _ -> str -- most likely invalid encoding + _ -> either (const str) getPayload . _runEncoding @s encf . toEncoding () $ str -- most likely a valid encoded string + + +data TestSuite = OneBitOnly | All + + +suite :: + TestSuite + -> (forall s . (Algorithm s "enc-pkg/encoding", KnownSymbol s) => + Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String + -> String + -> Property) + -> SpecWith () +suite _ prop = do + it "utf8" $ property $ prop @"enc-pkg/encoding:utf8" decString + it "jis_x_0208" $ property $ prop @"enc-pkg/encoding:jis_x_0208" decString + it "koi8_r" $ property $ prop @"enc-pkg/encoding:koi8_r" decString + it "koi8_u" $ property $ prop @"enc-pkg/encoding:koi8_u" decString + it "iso8859_1" $ property $ prop @"enc-pkg/encoding:iso8859_1" decString + it "iso8859_2" $ property $ prop @"enc-pkg/encoding:iso8859_2" decString + it "iso8859_3" $ property $ prop @"enc-pkg/encoding:iso8859_3" decString + it "iso8859_4" $ property $ prop @"enc-pkg/encoding:iso8859_4" decString + it "iso8859_5" $ property $ prop @"enc-pkg/encoding:iso8859_5" decString + it "iso8859_6" $ property $ prop @"enc-pkg/encoding:iso8859_6" decString + it "iso8859_7" $ property $ prop @"enc-pkg/encoding:iso8859_7" decString + it "iso8859_8" $ property $ prop @"enc-pkg/encoding:iso8859_8" decString + it "iso8859_9" $ property $ prop @"enc-pkg/encoding:iso8859_9" decString + it "iso8859_10" $ property $ prop @"enc-pkg/encoding:iso8859_10" decString + it "iso8859_11" $ property $ prop @"enc-pkg/encoding:iso8859_11" decString + it "iso8859_13" $ property $ prop @"enc-pkg/encoding:iso8859_13" decString + it "iso8859_14" $ property $ prop @"enc-pkg/encoding:iso8859_14" decString + it "iso8859_15" $ property $ prop @"enc-pkg/encoding:iso8859_15" decString + it "iso8859_16" $ property $ prop @"enc-pkg/encoding:iso8859_16" decString + it "cp1250" $ property $ prop @"enc-pkg/encoding:cp1250" decString + it "cp1251" $ property $ prop @"enc-pkg/encoding:cp1251" decString + it "cp1252" $ property $ prop @"enc-pkg/encoding:cp1252" decString + it "cp1253" $ property $ prop @"enc-pkg/encoding:cp1253" decString + it "cp1254" $ property $ prop @"enc-pkg/encoding:cp1254" decString + it "cp1255" $ property $ prop @"enc-pkg/encoding:cp1255" decString + it "cp1256" $ property $ prop @"enc-pkg/encoding:cp1256" decString + it "cp1257" $ property $ prop @"enc-pkg/encoding:cp1257" decString + it "cp1258" $ property $ prop @"enc-pkg/encoding:cp1258" decString + it "gb18030" $ property $ prop @"enc-pkg/encoding:gb18030" decString + it "macintosh" $ property $ prop @"enc-pkg/encoding:macintosh" decString + it "jis_x_0201" $ property $ prop @"enc-pkg/encoding:jis_x_0201" decString + it "cp437" $ property $ prop @"enc-pkg/encoding:cp437" decString + it "cp737" $ property $ prop @"enc-pkg/encoding:cp737" decString + it "cp775" $ property $ prop @"enc-pkg/encoding:cp775" decString + it "cp850" $ property $ prop @"enc-pkg/encoding:cp850" decString + it "cp852" $ property $ prop @"enc-pkg/encoding:cp852" decString + it "cp855" $ property $ prop @"enc-pkg/encoding:cp855" decString + it "cp857" $ property $ prop @"enc-pkg/encoding:cp857" decString + it "cp860" $ property $ prop @"enc-pkg/encoding:cp860" decString + it "cp861" $ property $ prop @"enc-pkg/encoding:cp861" decString + it "cp862" $ property $ prop @"enc-pkg/encoding:cp862" decString + it "cp863" $ property $ prop @"enc-pkg/encoding:cp863" decString + it "cp864" $ property $ prop @"enc-pkg/encoding:cp864" decString + it "cp865" $ property $ prop @"enc-pkg/encoding:cp865" decString + it "cp866" $ property $ prop @"enc-pkg/encoding:cp866" decString + it "cp869" $ property $ prop @"enc-pkg/encoding:cp869" decString + it "cp874" $ property $ prop @"enc-pkg/encoding:cp874" decString + + -- /encoding/ package issue, it allows encoding on invalid character that later fails during decode: + -- it "cp932" $ property $ prop @"enc-pkg/encoding:cp932" encString decString + + + +spec :: Spec +spec = + describe "Sanity" $ do + describe "save decode after encode" $ + suite All (propEncDec encString) + describe "save decode after validate" $ + suite All (propValidation encString validation) + +runSpec :: IO () +runSpec = hspec spec diff --git a/test/Test/SanitySpec.hs b/test/Test/SanitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/SanitySpec.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fwarn-unused-imports #-} + +-- | +module Test.SanitySpec where + + +import Data.TypedEncoding +import Data.TypedEncoding.Pkg.Encoding.Conv +import Data.TypedEncoding.Pkg.Encoding.Instances () + +import Data.TypedEncoding + +import Test.QuickCheck.Instances.ByteString () +import Test.Hspec +import Data.Either + +-- OneBitProblems are one bit encodings that somehow can encode chars > '\255' +data TestSuite = MultiBit | OneBit | OneBitProblems + +-- | encoding for one bit encodings should always fail string has chars > '\255' +-- this does not seem to be the case with some encodings like /cp1257/ which could be a bug +-- in encodings library +-- Even adding chars like \1057 (0x421) does not help e.g. /iso8859_5/ encodes it! +-- +expectToFailEnc :: forall s . (Algorithm s "enc-pkg/encoding") => String -> Encoding (Either EncodeEx) s "enc-pkg/encoding" () String -> Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String -> Bool +expectToFailEnc str encf decf = isLeft enc + where + enc = _runEncoding encf . toEncoding () $ str + + +-- | encoding does not fail on numbers 0-9 +expectSucceedEnc :: forall s . (Algorithm s "enc-pkg/encoding") => String -> Encoding (Either EncodeEx) s "enc-pkg/encoding" () String -> Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String -> Bool +expectSucceedEnc str encf decf = isRight enc + where + enc = _runEncoding encf . toEncoding () $ str + +suite :: + TestSuite + -> (forall s . (Algorithm s "enc-pkg/encoding") => + Encoding (Either EncodeEx) s "enc-pkg/encoding" () String + -> Decoding (Either UnexpectedDecodeEx) s "enc-pkg/encoding" () String + -> Bool) + -> SpecWith (Arg Bool) +suite which test = + case which of + MultiBit -> do + it "utf8" $ test @"enc-pkg/encoding:utf8" encString decString + it "jis_x_0208" $ test @"enc-pkg/encoding:jis_x_0208" encString decString + OneBitProblems -> do + it "iso8859_4" $ test @"enc-pkg/encoding:iso8859_4" encString decString + it "iso8859_10" $ test @"enc-pkg/encoding:iso8859_10" encString decString + it "iso8859_13" $ test @"enc-pkg/encoding:iso8859_13" encString decString + it "cp1257" $ test @"enc-pkg/encoding:cp1257" encString decString + it "gb18030" $ test @"enc-pkg/encoding:gb18030" encString decString + it "gb18030" $ test @"enc-pkg/encoding:gb18030" encString decString + OneBit -> do + it "koi8_r" $ test @"enc-pkg/encoding:koi8_r" encString decString + it "koi8_u" $ test @"enc-pkg/encoding:koi8_u" encString decString + it "iso8859_1" $ test @"enc-pkg/encoding:iso8859_1" encString decString + it "iso8859_2" $ test @"enc-pkg/encoding:iso8859_2" encString decString + it "iso8859_3" $ test @"enc-pkg/encoding:iso8859_3" encString decString + it "iso8859_5" $ test @"enc-pkg/encoding:iso8859_5" encString decString + it "iso8859_6" $ test @"enc-pkg/encoding:iso8859_6" encString decString + it "iso8859_7" $ test @"enc-pkg/encoding:iso8859_7" encString decString + it "iso8859_8" $ test @"enc-pkg/encoding:iso8859_8" encString decString + it "iso8859_9" $ test @"enc-pkg/encoding:iso8859_9" encString decString + it "iso8859_11" $ test @"enc-pkg/encoding:iso8859_11" encString decString + it "iso8859_14" $ test @"enc-pkg/encoding:iso8859_14" encString decString + it "iso8859_15" $ test @"enc-pkg/encoding:iso8859_15" encString decString + it "iso8859_16" $ test @"enc-pkg/encoding:iso8859_16" encString decString + it "cp1250" $ test @"enc-pkg/encoding:cp1250" encString decString + it "cp1251" $ test @"enc-pkg/encoding:cp1251" encString decString + it "cp1252" $ test @"enc-pkg/encoding:cp1252" encString decString + it "cp1253" $ test @"enc-pkg/encoding:cp1253" encString decString + it "cp1254" $ test @"enc-pkg/encoding:cp1254" encString decString + it "cp1255" $ test @"enc-pkg/encoding:cp1255" encString decString + it "cp1256" $ test @"enc-pkg/encoding:cp1256" encString decString + it "cp1258" $ test @"enc-pkg/encoding:cp1258" encString decString + it "macintosh" $ test @"enc-pkg/encoding:macintosh" encString decString + it "jis_x_0201" $ test @"enc-pkg/encoding:jis_x_0201" encString decString + it "cp437" $ test @"enc-pkg/encoding:cp437" encString decString + it "cp737" $ test @"enc-pkg/encoding:cp737" encString decString + it "cp850" $ test @"enc-pkg/encoding:cp850" encString decString + it "cp852" $ test @"enc-pkg/encoding:cp852" encString decString + it "cp855" $ test @"enc-pkg/encoding:cp855" encString decString + it "cp857" $ test @"enc-pkg/encoding:cp857" encString decString + it "cp860" $ test @"enc-pkg/encoding:cp860" encString decString + it "cp861" $ test @"enc-pkg/encoding:cp861" encString decString + it "cp862" $ test @"enc-pkg/encoding:cp862" encString decString + it "cp863" $ test @"enc-pkg/encoding:cp863" encString decString + it "cp864" $ test @"enc-pkg/encoding:cp864" encString decString + it "cp865" $ test @"enc-pkg/encoding:cp865" encString decString + it "cp866" $ test @"enc-pkg/encoding:cp866" encString decString + it "cp869" $ test @"enc-pkg/encoding:cp869" encString decString + it "cp874" $ test @"enc-pkg/encoding:cp874" encString decString + -- /encoding/ package issue, it allows encoding on invalid character that later fails during decode: + it "cp932" $ test @"enc-pkg/encoding:cp932" encString decString + + + +spec :: Spec +spec = + describe "Sanity" $ do + + -- /encoding/ package issue, numerous one-bit encodings encode chars > 255 just fine! + describe "> xFF expect to fail on onebit" $ + suite OneBit $ expectToFailEnc "\x100" + describe "> xFF expect to fail on onebit" $ + suite OneBitProblems $ fmap not . expectToFailEnc "\x100" + describe "succeed on digit 1" $ + suite OneBit $ expectSucceedEnc "1" -- fails on jis_x_0208 + describe "succeed on digit 1" $ + suite OneBitProblems $ expectSucceedEnc "1" + +runSpec :: IO () +runSpec = hspec spec diff --git a/typed-encoding-encoding.cabal b/typed-encoding-encoding.cabal new file mode 100644 --- /dev/null +++ b/typed-encoding-encoding.cabal @@ -0,0 +1,86 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 1d0bbf4ab8644c4775fdefb85f1315ea44bfd792d71390c2b95688603d3dc7eb + +name: typed-encoding-encoding +version: 0.1.0.0 +synopsis: Bridge between encoding and typed-encoding packages +description: Please see the README on GitHub at +category: Data, Text +homepage: https://github.com/rpeszek/typed-encoding-encoding#readme +bug-reports: https://github.com/rpeszek/typed-encoding-encoding/issues +author: Robert Peszek +maintainer: robpeszek@gmail.com +copyright: 2020 Robert Peszek +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/rpeszek/typed-encoding-encoding + +library + exposed-modules: + Data.TypedEncoding.Pkg.Encoding + Data.TypedEncoding.Pkg.Encoding.Conv + Data.TypedEncoding.Pkg.Encoding.Instances + Data.TypedEncoding.Pkg.Encoding.Warn.Instances + other-modules: + Paths_typed_encoding_encoding + hs-source-dirs: + src + ghc-options: -fwarn-unused-imports -fwarn-incomplete-patterns -fprint-explicit-kinds + build-depends: + base >=4.10 && <5 + , bytestring >=0.10 && <0.11 + , encoding >=0.8.5 && <0.9 + , typed-encoding >=0.4.1 && <0.5 + default-language: Haskell2010 + +test-suite typed-encoding-encoding-doctest + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_typed_encoding_encoding + hs-source-dirs: + doctest + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.10 && <5 + , bytestring >=0.10 && <0.11 + , doctest >=0.16 && <0.17 + , doctest-discover >=0.2 && <0.3 + , encoding >=0.8.5 && <0.9 + , typed-encoding >=0.4 && <0.5 + default-language: Haskell2010 + +test-suite typed-encoding-encoding-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.SafeDecodingSpec + Test.SanitySpec + Paths_typed_encoding_encoding + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck >=2.13.1 && <2.14 + , base >=4.10 && <5 + , bytestring >=0.10 && <0.11 + , doctest >=0.16 && <0.17 + , doctest-discover >=0.2 && <0.3 + , encoding >=0.8.5 && <0.9 + , hspec + , quickcheck-instances >=0.3.20 && <0.4 + , typed-encoding >=0.4.1 && <0.5 + , typed-encoding-encoding + default-language: Haskell2010