diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 Serokell + +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/serokell-util.cabal b/serokell-util.cabal new file mode 100644 --- /dev/null +++ b/serokell-util.cabal @@ -0,0 +1,131 @@ +name: serokell-util +version: 0.1.1 +synopsis: General-purpose functions by Serokell +homepage: http://gitlab.serokell.io/serokell-team/serokell-util +license: MIT +license-file: LICENSE +category: Utils +author: Serokell +maintainer: Serokell +copyright: 2016 Serokell +build-type: Simple +description: Serokell-util is a library consisting of functions, which + are not included in standard libraries, but are useful for + multiple projects. This library was created when it was + found that in new projects we need to use some utility + functions from existing projects and don't want to + copy-paste them. +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Serokell.AcidState + Serokell.AcidState.ExtendedState + Serokell.AcidState.Instances + Serokell.AcidState.Statistics + Serokell.AcidState.Util + Serokell.Arbitrary + Serokell.Aeson.Options + Serokell.Data.Memory.Units + Serokell.Data.Variant + Serokell.Util + Serokell.Util.Base16 + Serokell.Util.Base64 + Serokell.Util.Bench + Serokell.Util.Binary + Serokell.Util.Common + Serokell.Util.Concurrent + Serokell.Util.I18N + Serokell.Util.Parse + Serokell.Util.OptParse + Serokell.Util.Exceptions + Serokell.Util.Lens + Serokell.Util.StaticAssert + Serokell.Util.Text + Serokell.Util.Verify + other-modules: Serokell.Data.Variant.Class + Serokell.Data.Variant.Helpers + Serokell.Data.Variant.Serialization + Serokell.Data.Variant.Variant + Serokell.Util.Parse.Base64 + Serokell.Util.Parse.Common + Serokell.Util.Parse.Network + build-depends: QuickCheck >= 2.8.1 + , acid-state + , aeson + , aeson-extra + , base >= 4.8 && < 5 + , base16-bytestring + , base64-bytestring + , binary + , binary-orphans + , bytestring + , cereal + , cereal-vector + , containers + , clock + , data-msgpack >= 0.0.8 + , deepseq + , directory + , either + , exceptions + , extra + , filepath + , formatting + , hashable >= 1.2.4.0 + , lens + , mtl + , optparse-applicative + , parsec + , quickcheck-instances + , safecopy >= 0.9.0.1 + , scientific + , semigroups + , template-haskell + , text + , text-format + , time-units + , transformers + , unordered-containers >= 0.2.7.0 + , vector + , yaml + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fno-warn-orphans + default-extensions: OverloadedStrings + , RecordWildCards + , DeriveDataTypeable + , GeneralizedNewtypeDeriving + +test-suite serokell-test + main-is: Test.hs + other-modules: Test.Serokell.Data.Memory.UnitsSpec + Test.Serokell.Data.Variant.VariantSpec + Test.Serokell.Util.CommonSpec + Test.Serokell.Util.ByteStringSpec + Test.Serokell.Util.TextSpec + Spec + type: exitcode-stdio-1.0 + build-depends: aeson + , base >=4.8 + , binary + , bytestring + , cereal + , hspec >= 2.1.10 + , data-msgpack >= 0.0.8 + , QuickCheck >= 2.8.1 + , quickcheck-instances + , safecopy >= 0.9.0.1 + , scientific + , serokell-util + , text + , text-format + , unordered-containers >= 0.2.7.0 + , vector + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -Wall -fno-warn-orphans + default-extensions: OverloadedStrings + , RecordWildCards + , DeriveDataTypeable + , GeneralizedNewtypeDeriving diff --git a/src/Serokell/AcidState.hs b/src/Serokell/AcidState.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/AcidState.hs @@ -0,0 +1,10 @@ +-- | Re-export Serokell.AcidState.* modules. + +module Serokell.AcidState + ( + module Exports + ) where + +import Serokell.AcidState.ExtendedState as Exports +import Serokell.AcidState.Instances () +import Serokell.AcidState.Util as Exports diff --git a/src/Serokell/AcidState/ExtendedState.hs b/src/Serokell/AcidState/ExtendedState.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/AcidState/ExtendedState.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | The idea of ExtendedState is to store information about location +-- of the state (either FilePath or memory). + +module Serokell.AcidState.ExtendedState + ( ExtendedState (..) + , closeExtendedState + , extendedStateToAcid + , openLocalExtendedState + , openMemoryExtendedState + , queryExtended + , tidyExtendedState + , updateExtended + ) where + +import Control.Monad.Extra (whenM) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Acid (AcidState, EventResult, EventState, IsAcidic, + QueryEvent, UpdateEvent, closeAcidState, + openLocalStateFrom) +import Data.Acid.Advanced (query', update') +import Data.Acid.Memory (openMemoryState) +import Data.Typeable (Typeable) + +import System.Directory (doesDirectoryExist, removeDirectoryRecursive) + +import Serokell.AcidState.Util (tidyLocalState) + +-- | ExtendedState is like usual AcidState, but also stores +-- information about FilePath (unless it's in memory). +data ExtendedState st + = ESLocal (AcidState st) + FilePath + | ESMemory (AcidState st) + +-- | Convert ExtendedState to AcidState. +extendedStateToAcid :: ExtendedState st -> AcidState st +extendedStateToAcid (ESLocal s _) = s +extendedStateToAcid (ESMemory s) = s + +-- | Like query', but works on ExtendedState. +queryExtended + :: (EventState event ~ st, QueryEvent event, MonadIO m) + => ExtendedState st -> event -> m (EventResult event) +queryExtended st = query' (extendedStateToAcid st) + +-- | Like update', but works on ExtendedState. +updateExtended + :: (EventState event ~ st, UpdateEvent event, MonadIO m) + => ExtendedState st -> event -> m (EventResult event) +updateExtended st = update' (extendedStateToAcid st) + +-- | Like openLocalStateFrom, but returns ExtendedState and operates +-- in MonadIO. +openLocalExtendedState + :: (IsAcidic st, Typeable st, MonadIO m) + => Bool -> FilePath -> st -> m (ExtendedState st) +openLocalExtendedState deleteIfExists fp st = do + whenM ((deleteIfExists &&) <$> liftIO (doesDirectoryExist fp)) $ + liftIO $ removeDirectoryRecursive fp + liftIO $ flip ESLocal fp <$> openLocalStateFrom fp st + +-- | Like openMemoryState, but returns ExtendedState and operates in +-- MonadIO. +openMemoryExtendedState + :: (IsAcidic st, Typeable st, MonadIO m) + => st -> m (ExtendedState st) +openMemoryExtendedState st = liftIO $ ESMemory <$> openMemoryState st + +-- | Like closeAcidState, but operates on ExtendedState and in +-- MonadIO. +closeExtendedState :: MonadIO m => ExtendedState st -> m () +closeExtendedState = liftIO . closeAcidState . extendedStateToAcid + +-- | Like tidyLocalState, but operates on ExtendedState. +tidyExtendedState :: MonadIO m => ExtendedState st -> m () +tidyExtendedState (ESLocal st fp) = tidyLocalState st fp +tidyExtendedState (ESMemory _) = return () diff --git a/src/Serokell/AcidState/Instances.hs b/src/Serokell/AcidState/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/AcidState/Instances.hs @@ -0,0 +1,31 @@ +-- | Helper instances for Acid State to remove boilerplate and introduce +-- redundant instances for other data types. + +module Serokell.AcidState.Instances where + +import Control.Exception (throw) +import Control.Monad.Catch (MonadThrow (throwM)) + +import Data.Acid (Query, Update) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS hiding (HashSet) +import Data.SafeCopy (SafeCopy (getCopy, putCopy), contain, + safeGet, safePut) + +-- | Usually Queries shouldn't throw anything. This is a dirty hack. +instance MonadThrow (Query s) where + throwM = throw + +instance MonadThrow (Update s) where + throwM = throw + +instance (Eq a, Hashable a, SafeCopy a) => SafeCopy (HashSet a) where + putCopy = contain . safePut . HS.toList + getCopy = contain $ HS.fromList <$> safeGet + +instance (Eq a, Hashable a, SafeCopy a, SafeCopy b) => SafeCopy (HashMap a b) where + putCopy = contain . safePut . HM.toList + getCopy = contain $ HM.fromList <$> safeGet diff --git a/src/Serokell/AcidState/Statistics.hs b/src/Serokell/AcidState/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/AcidState/Statistics.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} + +-- | Collect statistics about acid-state database. + +module Serokell.AcidState.Statistics + ( StoragePart (..) + + , estimateMemoryUsage + ) where + +import Control.Lens (Getter, (^.)) +import qualified Data.ByteString as BS (length) +import Data.SafeCopy (SafeCopy, safePut) +import Data.Serialize.Put (runPut) +import Data.Text (Text) + +import Serokell.Data.Memory.Units (MemoryUnit, fromBytes) + +type PartName = Text + +data StoragePart storage = forall part. SafeCopy part => + StoragePart + { spName :: PartName + , spGetter :: Getter storage part + } + +estimateMemoryUsage + :: MemoryUnit unit + => [StoragePart s] -> s -> [(PartName, unit)] +estimateMemoryUsage parts storage = map processPart parts + where + processPart StoragePart{..} = + ( spName + , fromBytes . toInteger . BS.length . runPut . safePut . (storage ^.) $ + spGetter) diff --git a/src/Serokell/AcidState/Util.hs b/src/Serokell/AcidState/Util.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/AcidState/Util.hs @@ -0,0 +1,56 @@ +-- | Some useful functions to work with Data.Acid. + +module Serokell.AcidState.Util + ( + -- | Simple helpers + exceptStateToUpdate + , exceptStateToUpdateGeneric + , readerToQuery + , stateToUpdate + + -- | Utilities + , createAndDiscardArchive + , tidyLocalState + ) where + +import Control.Exception (Exception, throw) +import Control.Monad.Except (ExceptT, runExceptT) +import Control.Monad.Reader (Reader, asks, runReader) +import Control.Monad.State (State, runState, state) +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Acid (AcidState, Query, Update, createArchive, + createCheckpoint) +import System.Directory (removeDirectoryRecursive) +import System.FilePath (()) + +readerToQuery :: Reader s a -> Query s a +readerToQuery = asks . runReader + +stateToUpdate :: State s a -> Update s a +stateToUpdate = state . runState + +exceptStateToUpdate + :: (Exception e) + => ExceptT e (State s) a -> Update s a +exceptStateToUpdate = exceptStateToUpdateGeneric id + +exceptStateToUpdateGeneric + :: (Exception exc) + => (e -> exc) -> ExceptT e (State s) a -> Update s a +exceptStateToUpdateGeneric toException u = + state $ + runState $ + do res <- runExceptT u + either (throw . toException) return res + +-- | Archive unnecessary data (see createArchive docs for details) and +-- discard it. Works for local state. +createAndDiscardArchive :: MonadIO m => AcidState st -> FilePath -> m () +createAndDiscardArchive st path = + liftIO $ createArchive st >> removeDirectoryRecursive (path "Archive") + +-- | Apply all updates and remove all data from local state which is +-- unnecessary for state restoration. +tidyLocalState :: MonadIO m => AcidState st -> FilePath -> m () +tidyLocalState st path = + liftIO (createCheckpoint st) >> createAndDiscardArchive st path diff --git a/src/Serokell/Aeson/Options.hs b/src/Serokell/Aeson/Options.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Aeson/Options.hs @@ -0,0 +1,59 @@ +-- | Options used to derive FromJSON/ToJSON instance. These options +-- generally comply to our style regarding names. Of course sometimes +-- they don't fit one's needs, so treat them as just sensible +-- defaults. + +module Serokell.Aeson.Options + ( defaultOptions + , leaveTagOptions + , defaultOptionsPS + ) where + +import qualified Data.Aeson.TH as A +import Data.Char (isLower, isPunctuation, isUpper, toLower) +import Data.List (findIndex) + +headToLower :: String -> String +headToLower [] = undefined +headToLower (x:xs) = toLower x : xs + +stripFieldPrefix :: String -> String +stripFieldPrefix = dropWhile (not . isUpper) + +dropPunctuation :: String -> String +dropPunctuation = filter (not . isPunctuation) + +stripConstructorPrefix :: String -> String +stripConstructorPrefix t = + maybe t (flip drop t . decrementSafe) $ findIndex isLower t + where + decrementSafe 0 = 0 + decrementSafe i = i - 1 + +-- | These options do the following transformations: +-- 1. Names of field +-- records are assumed to be camelCased, `camel` part is removed, +-- `Cased` part is converted to `cased`. So `camelCased` becomes +-- `cased`. Also all punctuation symbols are dropped before doing it. +-- 2. Constructors are assumed to start with some capitalized prefix +-- (which finished right before the last capital letter). This prefix +-- is dropped and then the first letter is lowercased. +defaultOptions :: A.Options +defaultOptions = + A.defaultOptions + { A.fieldLabelModifier = headToLower . stripFieldPrefix . dropPunctuation + , A.constructorTagModifier = headToLower . stripConstructorPrefix + , A.sumEncoding = A.ObjectWithSingleField + } + +-- | These options are the same as `defaultOptions`, but they don't +-- modify constructor tags. +leaveTagOptions :: A.Options +leaveTagOptions = defaultOptions { A.constructorTagModifier = id } + +-- | Options used for communication with PureScript by default. +defaultOptionsPS :: A.Options +defaultOptionsPS = + A.defaultOptions + { A.constructorTagModifier = headToLower . stripConstructorPrefix + } diff --git a/src/Serokell/Arbitrary.hs b/src/Serokell/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Arbitrary.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Arbitrary instances for Serokell datatypes +module Serokell.Arbitrary + ( VariantNoBytes (..) + , VariantOnlyBytes (..) + ) where + +import Data.ByteString as BS hiding (zip) +import qualified Data.HashMap.Lazy as H (fromList) +import Data.Vector (fromList) +import GHC.Generics (Generic) +import Test.QuickCheck (Arbitrary (..), Gen, choose, + genericShrink, frequency, oneof, + sized) +import Test.QuickCheck.Instances () + +import Serokell.Data.Variant.Variant (Variant (..)) +import qualified Serokell.Util.Base64 as S + +instance Arbitrary S.JsonByteString where + arbitrary = S.JsonByteString <$> (arbitrary :: Gen BS.ByteString) + +newtype VariantNoBytes = NoBytes + { getVariant :: Variant + } deriving (Show, Eq, Generic) + +newtype VariantOnlyBytes = OnlyBytes + { getVarBytes :: Variant + } deriving (Show, Eq, Generic) + +instance Arbitrary VariantOnlyBytes where + arbitrary = OnlyBytes . VarBytes <$> arbitrary + shrink = genericShrink + +instance Arbitrary VariantNoBytes where + arbitrary = NoBytes <$> (sized $ \n -> genVariant (n*50 + 1)) + shrink = genericShrink + +instance Arbitrary Variant where + arbitrary = sized $ \n -> genVariant (n*50 + 1) + shrink = genericShrink + +-- | Generate something with at most N constructors. Say how many constructors +-- actually are in the generated 'Variant'. Because encoding 'VarBytes' into +-- JSON and then decoding it presents a problem - it becomes a 'VarString', +-- and it is difficult to tell whether it was decoded from a 'VarBytes' or +-- another 'VarString' - this generating function won't generate this +-- constructor unless given a true boolean flag. +genVariant :: Int -> Gen Variant +genVariant 1 = genFlatVariant +genVariant n = do + frequency + -- No reason for “3”, it just works well. + [ (3, genFlatVariant) + -- The more constructors we have to generate, the more likely we are + -- to choose something nested instead of something flat. + , (truncate (logBase 2 (fromIntegral n) :: Double), + oneof [genListVariant n, genMapVariant n]) + ] + +genFlatVariant :: Gen Variant +genFlatVariant = oneof $ + [ pure VarNone + , VarBool <$> arbitrary + , VarInt <$> arbitrary + , VarUInt <$> arbitrary + , VarFloat <$> arbitrary + , VarString <$> arbitrary + ] + +-- | Generate a list of variants, using at most N constructors in total. +genBoundedVariants :: Int -> Gen [Variant] +genBoundedVariants 0 = return [] +genBoundedVariants n = do + v_cons <- choose (1, n) + (:) <$> genVariant v_cons + <*> genBoundedVariants (n-v_cons) + +genListVariant :: Int -> Gen Variant +genListVariant n = VarList . fromList <$> genBoundedVariants (n-1) + +genMapVariant :: Int -> Gen Variant +genMapVariant n = do + keys <- genBoundedVariants ((n-1) `div` 2) + vals <- genBoundedVariants ((n-1) `div` 2) + -- Lengths of keys and vals may not match and so we would get less + -- constructors due to truncation, but we don't care. + return $ VarMap $ H.fromList $ zip keys vals diff --git a/src/Serokell/Data/Memory/Units.hs b/src/Serokell/Data/Memory/Units.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Memory/Units.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Memory units. + +module Serokell.Data.Memory.Units + ( + -- | Type class + MemoryUnit (..) + + -- | Concrete types + , Byte + , Kilobyte + , Megabyte + , Gigabyte + , Terabyte + + -- | Pretty printing + , unitBuilder + , memory + + -- | Helpers + , toBytes + , fromBytes + , convertUnit + ) where + +import Data.Binary (Binary) +import Data.Proxy (Proxy (Proxy)) +import Data.SafeCopy (SafeCopy) +import Data.Serialize (Serialize) +import Data.Text.Lazy.Builder (Builder) +import Data.Typeable (Typeable) +import Formatting (bprint, stext, (%)) +import qualified Formatting as Fmt +import GHC.Generics (Generic) + +import Serokell.Util.Text (showFixedPretty') + +import Test.QuickCheck (Arbitrary) + +class Integral unit => MemoryUnit unit where + -- | This value is n iff (1 :: unit) is n bytes. + bytesMultiplier :: Proxy unit -> Integer + +-- | Convert given memory unit into integer representing bytes. +toBytes + :: forall unit. + MemoryUnit unit + => unit -> Integer +toBytes mu = toInteger mu * bytesMultiplier proxy + where + proxy :: Proxy unit + proxy = Proxy + +-- | Convert given number of bytes into memory unit, flooring value if +-- necessary. +fromBytes + :: forall unit. + MemoryUnit unit + => Integer -> unit +fromBytes bytes = fromInteger $ bytes `div` bytesMultiplier proxy + where + proxy :: Proxy unit + proxy = Proxy + +-- | Conversion between memory units. +convertUnit :: (MemoryUnit a, MemoryUnit b) => a -> b +convertUnit = fromBytes . toBytes + +-- | Construct Text Builder. +unitBuilder :: MemoryUnit unit => unit -> Builder +unitBuilder n@(toBytes -> bytes) + | bytes == 0 = "0" + | bytes < 0 = mconcat ["-", unitBuilder n] + | otherwise = bprint (stext % " " % stext) (showFixedPretty' 3 value) suffix + where + suffixes = ["B", "KiB", "MiB", "GiB", "TiB", "Pib", "EiB", "ZiB", "YiB"] + bytesDouble :: Double + bytesDouble = realToFrac bytes + order = min (length suffixes - 1) (floor $ logBase 2 bytesDouble / 10) + suffix = suffixes !! order + value = bytesDouble / realToFrac ((2 :: Integer) ^ (order * 10)) + +-- | Formatter for `formatting` library. +memory :: MemoryUnit unit => Fmt.Format r (unit -> r) +memory = Fmt.later unitBuilder + +pow10 :: Num n => Int -> n +pow10 = (10 ^) + +newtype Byte = + Byte Integer + deriving (Show,Eq,Num,Typeable,Integral,Real,Enum,Ord,Generic,Serialize,Binary, Arbitrary) + +instance SafeCopy Byte + +instance MemoryUnit Byte where + bytesMultiplier Proxy = pow10 0 + +newtype Kilobyte = + Kilobyte Integer + deriving (Show,Eq,Num,Typeable,Integral,Real,Enum,Ord,Generic,Serialize,Arbitrary) + +instance SafeCopy Kilobyte + +instance MemoryUnit Kilobyte where + bytesMultiplier Proxy = pow10 3 + +-- P. S. Feel free to add more. + +newtype Megabyte = + Megabyte Integer + deriving (Show,Eq,Num,Typeable,Integral,Real,Enum,Ord,Generic,Serialize,Arbitrary) + +instance SafeCopy Megabyte + +instance MemoryUnit Megabyte where + bytesMultiplier Proxy = pow10 6 + +newtype Gigabyte = + Gigabyte Integer + deriving (Show,Eq,Num,Typeable,Integral,Real,Enum,Ord,Generic,Serialize,Arbitrary) + +instance SafeCopy Gigabyte + +instance MemoryUnit Gigabyte where + bytesMultiplier Proxy = pow10 9 + +newtype Terabyte = + Terabyte Integer + deriving (Show,Eq,Num,Typeable,Integral,Real,Enum,Ord,Generic,Serialize,Arbitrary) + +instance SafeCopy Terabyte + +instance MemoryUnit Terabyte where + bytesMultiplier Proxy = pow10 12 diff --git a/src/Serokell/Data/Variant.hs b/src/Serokell/Data/Variant.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Variant.hs @@ -0,0 +1,14 @@ +-- | Variant is a data type with dynamic structure. It's designed to +-- be very generic, but also efficient. You can choose whatever data +-- layout you want. This module re-exports modules relevant to this +-- type. + +module Serokell.Data.Variant + ( + module Export + ) where + +import Serokell.Data.Variant.Class as Export +import Serokell.Data.Variant.Helpers as Export +import Serokell.Data.Variant.Serialization () +import Serokell.Data.Variant.Variant as Export diff --git a/src/Serokell/Data/Variant/Class.hs b/src/Serokell/Data/Variant/Class.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Variant/Class.hs @@ -0,0 +1,31 @@ +-- | Type class for values which can be converted to/from Variant. +-- Also contains some instances. + +module Serokell.Data.Variant.Class + ( ToVariant (toVariant) + , FromVariant (fromVariant) + ) where + +import Control.Monad.Catch (MonadThrow) +import Formatting (build, sformat, (%)) + +import Serokell.Data.Variant.Variant (Variant (..)) +import Serokell.Util.Exceptions (throwText) + +class ToVariant v where + toVariant :: v -> Variant + +class FromVariant v where + -- TODO: it won't be used now, so I didn't think much about this type. + -- Maybe it's not the best idea to use MonadThrow here. + fromVariant :: MonadThrow m => Variant -> m v + +instance ToVariant Bool where + toVariant = VarBool + +instance ToVariant Double where + toVariant = VarFloat + +instance FromVariant Double where + fromVariant (VarFloat v) = pure v + fromVariant v = throwText $ sformat ("value is not Double: " % build) v diff --git a/src/Serokell/Data/Variant/Helpers.hs b/src/Serokell/Data/Variant/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Variant/Helpers.hs @@ -0,0 +1,21 @@ +-- | Helper functions for convenient work with Variant. Feel free to +-- add more if you need. + +module Serokell.Data.Variant.Helpers + ( none + , varMap + ) where + +import Data.Foldable (Foldable (toList)) +import qualified Data.HashMap.Strict as HM hiding (HashMap) + +import Serokell.Data.Variant.Variant (Variant (..)) + +-- | Shorter alias for VarNone. +none :: Variant +none = VarNone + +-- | Create VarMap from Foldable containing pairs of Variants. +-- TODO: maybe use better approach like `a := b` to create KeyValuePair. +varMap :: Foldable t => t (Variant, Variant) -> Variant +varMap = VarMap . HM.fromList . toList diff --git a/src/Serokell/Data/Variant/Serialization.hs b/src/Serokell/Data/Variant/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Variant/Serialization.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE TupleSections #-} + +-- | This module contains serialization logic for Variant type. +-- Feel free to add serialization to/from other formats if you need it. + +module Serokell.Data.Variant.Serialization + ( + ) where + +import qualified Data.Aeson as Aeson +import Data.Bifunctor (bimap) +import Data.Binary (Binary) +import Data.Binary.Orphans () +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import qualified Data.MessagePack as MP +import Data.SafeCopy (SafeCopy) +import Data.Scientific (floatingOrInteger) +import qualified Data.Serialize as Cereal +import Data.Text (Text) +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import Data.Vector.Serialize () + +import Serokell.Data.Variant.Variant (VarMap, Variant (..)) +import Serokell.Util.Base64 (JsonByteString (JsonByteString)) +import Serokell.Util.Text (show') + +-- —————————JSON serialization————————— -- +-- Since there is no bijection between Variant and JSON Value, there are some +-- non-trivial things: +-- 1. decode . encode ≠ id. For example, (decode . encode) for VarBytes +-- will return VarString. +-- 2. Bytes are encoded in base64 encoding. +-- 3. If map contains key which is not a string, this key is converted to +-- string using Buildable instance. Usually you should avoid JSON +-- serialization for such maps. +-- 4. For numbers there is smart deserialization which tries to guess right +-- type (signed int/unsigned int/float). +-- If number is floating, VarFloat will be returned. For integer values +-- result type depends on sign (negative ⇒ Int, otherwise UInt). + +varMapToObject :: VarMap -> Aeson.Object +varMapToObject = HM.fromList . map (bimap show' Aeson.toJSON) . HM.toList + +instance Aeson.ToJSON Variant where + toJSON VarNone = Aeson.Null + toJSON (VarBool v) = Aeson.toJSON v + toJSON (VarInt v) = Aeson.toJSON v + toJSON (VarUInt v) = Aeson.toJSON v + toJSON (VarFloat v) = Aeson.toJSON v + toJSON (VarBytes v) = Aeson.toJSON . JsonByteString $ v + toJSON (VarString v) = Aeson.toJSON v + toJSON (VarList v) = Aeson.toJSON v + toJSON (VarMap v) = Aeson.Object . varMapToObject $ v + toEncoding VarNone = Aeson.toEncoding Aeson.Null + toEncoding (VarBool v) = Aeson.toEncoding v + toEncoding (VarInt v) = Aeson.toEncoding v + toEncoding (VarUInt v) = Aeson.toEncoding v + toEncoding (VarFloat v) = Aeson.toEncoding v + toEncoding (VarBytes v) = Aeson.toEncoding . JsonByteString $ v + toEncoding (VarString v) = Aeson.toEncoding v + toEncoding (VarList v) = Aeson.toEncoding v + toEncoding (VarMap v) = Aeson.toEncoding . varMapToObject $ v + +instance Aeson.FromJSON Variant where + parseJSON Aeson.Null = pure VarNone + parseJSON (Aeson.Bool v) = pure . VarBool $ v + parseJSON (Aeson.Number v) = + pure . either VarFloat convertInt . floatingOrInteger $ v + where + convertInt :: Integer -> Variant + convertInt i + | i < 0 = VarInt $ fromIntegral i + | otherwise = VarUInt $ fromIntegral i + parseJSON (Aeson.String v) = pure . VarString $ v + parseJSON (Aeson.Array v) = fmap VarList . mapM Aeson.parseJSON $ v + parseJSON (Aeson.Object v) = + fmap (VarMap . HM.fromList) . + mapM + (\(key,val) -> + (VarString key, ) <$> Aeson.parseJSON val) . + HM.toList $ + v + +-- —————————Cereal and SafeCopy serialization————————— -- +-- This serialization is very simple: first byte is tag followed by actual value. +-- `decode . encode` should be `id`. + +-- TODO: move it somewhere?? +instance Cereal.Serialize Text where + put = Cereal.put . TE.encodeUtf8 + get = TE.decodeUtf8 <$> Cereal.get + +instance (Eq a, Hashable a, Cereal.Serialize a, Cereal.Serialize b) => + Cereal.Serialize (HashMap a b) where + put = Cereal.put . HM.toList + get = HM.fromList <$> Cereal.get + +instance Cereal.Serialize Variant + +instance SafeCopy Variant + +-- —————————MessagePack serialization————————— -- +-- MessagePack data structure is very close to Variant. However, note that: +-- 1. We are using strange library where Object type doesn't cover all +-- possible objects. For example, there is only `Int` for integers. +-- So every integer number is converted to `Int` (which may be imprecise). +-- Decoding checks sign of input (like JSON). +-- 2. MessagePack distinguishes between Float and Double while we don't. +-- 3. ObjectExt can't be decoded. + +instance MP.MessagePack Variant where + toObject VarNone = MP.ObjectNil + toObject (VarBool v) = MP.ObjectBool v + toObject (VarInt v) = MP.ObjectInt $ fromIntegral v + toObject (VarUInt v) = MP.ObjectInt $ fromIntegral v + toObject (VarFloat v) = MP.ObjectDouble v + toObject (VarBytes v) = MP.ObjectBin v + toObject (VarString v) = MP.ObjectStr v + toObject (VarList v) = MP.ObjectArray . fmap MP.toObject . V.toList $ v + toObject (VarMap v) = + MP.ObjectMap . + fmap (bimap MP.toObject MP.toObject) . HM.toList $ + v + fromObject MP.ObjectNil = pure VarNone + fromObject (MP.ObjectBool v) = pure . VarBool $ v + fromObject (MP.ObjectInt v) | v < 0 = pure . VarInt . fromIntegral $ v + | otherwise = pure . VarUInt . fromIntegral $ v + fromObject (MP.ObjectFloat v) = pure . VarFloat . realToFrac $ v + fromObject (MP.ObjectDouble v) = pure . VarFloat $ v + fromObject (MP.ObjectStr v) = pure . VarString $ v + fromObject (MP.ObjectBin v) = pure . VarBytes $ v + fromObject (MP.ObjectArray v) = fmap (VarList . V.fromList) + . mapM MP.fromObject + $ v + fromObject (MP.ObjectMap v) = + fmap (VarMap . HM.fromList) . + mapM + (\(a,b) -> + (,) <$> MP.fromObject a <*> MP.fromObject b) $ + v + fromObject (MP.ObjectExt _ _) = fail "Can't deserialize ObjectExt" + +-- —————————Binary serialization————————— -- +-- Here we use Generic support, it should be good enough. +instance Binary Variant diff --git a/src/Serokell/Data/Variant/Variant.hs b/src/Serokell/Data/Variant/Variant.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Data/Variant/Variant.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Variant type. + +module Serokell.Data.Variant.Variant + ( Variant (..) + , VarList + , VarMap + ) where + +import Control.DeepSeq (NFData) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable (hashWithSalt)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import Data.Int (Int64) +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Data.Text.Buildable (Buildable (build)) +import Data.Vector (Vector) +import qualified Data.Vector as V hiding (Vector) +import Data.Word (Word64) +import GHC.Exts (IsList (..)) +import GHC.Generics (Generic) + +import qualified Serokell.Util.Base16 as B16 +import Serokell.Util.Text (listBuilderJSONIndent, mapBuilder) + +type VarList = Vector Variant +type VarMap = HashMap Variant Variant + +-- | Variant is intended to store arbitrary data in arbitrary +-- format. You are free to choose data layout. +data Variant + = VarNone -- ^ None, i. e. no value. + | VarBool !Bool -- ^ Boolean value. + | VarInt !Int64 -- ^ Signed integer number. + | VarUInt !Word64 -- ^ Unsigned integer number. + | VarFloat !Double -- ^ IEEE 754 double precision floating point number. + | VarBytes !ByteString -- ^ Raw bytes. + | VarString !Text -- ^ Unicode string. + | VarList !VarList -- ^ List of Variants. + | VarMap !VarMap -- ^ Map (with unique keys) from Variant to Variant. + deriving (Show,Eq,Generic) + +instance Buildable Variant where + build VarNone = "None" + build (VarBool v) = build v + build (VarInt v) = build v + build (VarUInt v) = build v + build (VarFloat v) = build v + build (VarBytes v) = build . B16.encode $ v + build (VarString v) = build v + build (VarList v) = listBuilderJSONIndent 2 v + build (VarMap v) = mapBuilder . HM.toList $ v + +instance Hashable (Vector Variant) where + hashWithSalt salt = V.foldr' (flip hashWithSalt) (hashWithSalt salt ()) + +instance Hashable Variant + +instance IsString Variant where + fromString = VarString . fromString + +instance IsList Variant where + type Item Variant = Variant + toList (VarList v) = toList v + toList _ = error "toList: not a list" + fromList = VarList . fromList + +instance NFData Variant diff --git a/src/Serokell/Util.hs b/src/Serokell/Util.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util.hs @@ -0,0 +1,17 @@ +-- | Re-export everything from Serokell.Util.* + +module Serokell.Util + ( + module Exports + ) where + +import Serokell.Util.Bench as Exports +import Serokell.Util.Binary as Exports +import Serokell.Util.Common as Exports +import Serokell.Util.Concurrent as Exports +import Serokell.Util.Exceptions as Exports +import Serokell.Util.Lens as Exports +import Serokell.Util.OptParse as Exports +import Serokell.Util.StaticAssert as Exports +import Serokell.Util.Text as Exports +import Serokell.Util.Verify as Exports diff --git a/src/Serokell/Util/Base16.hs b/src/Serokell/Util/Base16.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Base16.hs @@ -0,0 +1,39 @@ +-- | Base16 encoding/decoding. + +module Serokell.Util.Base16 + ( encode + , decode + , formatBase16 + , base16F + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as B16 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Text.Lazy.Builder (Builder, fromText) +import Formatting (Format, later, sformat, stext, (%)) + +-- | Apply base16 encoding to strict ByteString. +encode :: BS.ByteString -> T.Text +encode = TE.decodeUtf8 . B16.encode + +-- | Decode base16-encoded ByteString. +decode :: T.Text -> Either T.Text BS.ByteString +decode = handleError . B16.decode . TE.encodeUtf8 + where + handleError (res,rest) + | BS.null rest = pure res + | otherwise = + Left $ + sformat + ("suffix is not in base-16 format: " % stext) + (TE.decodeUtf8 rest) + +-- | Construct Builder from bytestring formatting it in Base16. +formatBase16 :: BS.ByteString -> Builder +formatBase16 = fromText . encode + +-- | Format which uses Base16 to print bytestring. +base16F :: Format r (BS.ByteString -> r) +base16F = later formatBase16 diff --git a/src/Serokell/Util/Base64.hs b/src/Serokell/Util/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Base64.hs @@ -0,0 +1,74 @@ +-- | Base64 encoding/decoding. + +module Serokell.Util.Base64 + ( encode + , decode + , encodeUrl + , decodeUrl + , formatBase64 + , base64F + , JsonByteString (..) + , JsonByteStringDeprecated (..) + ) where + +import Control.Monad ((>=>)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base64.URL as B64url +import Data.Either.Combinators (mapLeft) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Data.Text.Lazy.Builder (Builder, fromText) +import Formatting (Format, later) + +-- | Apply base64 encoding to strict ByteString. +encode :: BS.ByteString -> T.Text +encode = decodeUtf8 . B64.encode + +-- | Decode base64-encoded ByteString. +decode :: T.Text -> Either T.Text BS.ByteString +decode = mapLeft T.pack . B64.decode . encodeUtf8 + +-- | Apply base64url encoding to strict ByteString. +encodeUrl :: BS.ByteString -> T.Text +encodeUrl = decodeUtf8 . B64url.encode + +-- | Decode base64url-encoded ByteString. +decodeUrl :: T.Text -> Either T.Text BS.ByteString +decodeUrl = mapLeft T.pack . B64url.decode . encodeUtf8 + +-- | Construct Builder from bytestring formatting it in Base64. +formatBase64 :: BS.ByteString -> Builder +formatBase64 = fromText . encode + +-- | Format which uses Base64 to print bytestring. +base64F :: Format r (BS.ByteString -> r) +base64F = later formatBase64 + +-- | Wrapper on top of ByteString with JSON serialization (in base64 +-- encoding). +newtype JsonByteString = JsonByteString + { getJsonByteString :: BS.ByteString + } + +instance ToJSON JsonByteString where + toJSON = toJSON . encode . getJsonByteString + +instance FromJSON JsonByteString where + parseJSON = + parseJSON >=> + either (fail . T.unpack) (pure . JsonByteString) . decode + +------------ Deprecated-------------- +newtype JsonByteStringDeprecated = JsonByteStringDeprecated + { getJsonByteStringDeprecated :: BS.ByteString + } + +instance ToJSON JsonByteStringDeprecated where + toJSON = toJSON . encodeUrl . getJsonByteStringDeprecated + +instance FromJSON JsonByteStringDeprecated where + parseJSON = + parseJSON >=> + either (fail . T.unpack) (pure . JsonByteStringDeprecated) . decodeUrl diff --git a/src/Serokell/Util/Bench.hs b/src/Serokell/Util/Bench.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Bench.hs @@ -0,0 +1,74 @@ +-- | Benchmark related utils. + +module Serokell.Util.Bench + ( getWallTime + , getCpuTime + , ElapsedTime (..) + , measureTime + , measureTime_ + , perSecond + ) where + +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Text.Buildable (Buildable (build)) +import Data.Time.Units (Nanosecond, TimeUnit, convertUnit) +import Formatting (bprint, shown, (%)) +import System.Clock (Clock (..), TimeSpec, diffTimeSpec, + getTime, toNanoSecs) + +-- | Get current wall-clock time as any time unit. +getWallTime :: (MonadIO m, TimeUnit a) => m a +getWallTime = timeSpecToUnit <$> getTime' Realtime + +-- | Get current CPU time as any time unit. +getCpuTime :: (MonadIO m, TimeUnit a) => m a +getCpuTime = timeSpecToUnit <$> getTime' ProcessCPUTime + +timeSpecToUnit + :: TimeUnit a + => TimeSpec -> a +timeSpecToUnit = + convertUnit . (fromIntegral :: Integer -> Nanosecond) . toNanoSecs + +-- | Data type describing time passed during execution of something. +data ElapsedTime = ElapsedTime + { elapsedCpuTime :: TimeSpec + , elapsedWallTime :: TimeSpec + } deriving (Show) + +instance Buildable ElapsedTime where + build ElapsedTime{..} = + bprint + ("(CPU time = " % shown % ", wall time = " % shown % ")") + elapsedCpuTime + elapsedWallTime + +getTime' :: MonadIO m => Clock -> m TimeSpec +getTime' = liftIO . getTime + +-- | Run given action and measure how much time it took. +measureTime :: MonadIO m => m a -> m (ElapsedTime, a) +measureTime action = do + cpuTimeBefore <- getTime' ProcessCPUTime + wallTimeBefore <- getTime' Realtime + res <- action + wallTimeAfter <- getTime' Realtime + cpuTimeAfter <- getTime' ProcessCPUTime + return + ( ElapsedTime + { elapsedCpuTime = cpuTimeAfter `diffTimeSpec` cpuTimeBefore + , elapsedWallTime = wallTimeAfter `diffTimeSpec` wallTimeBefore + } + , res) + +-- | Run given action and measure how much time it took, discarding +-- result of action. +measureTime_ :: MonadIO m => m a -> m ElapsedTime +measureTime_ = fmap fst . measureTime + +-- | Given number of actions executed during some time, this function +-- calculates how much actions were executed per second (on average). +perSecond :: (Real a, Fractional b) => a -> TimeSpec -> b +perSecond n time = + fromRational $ + toRational n / (fromIntegral (max 1 $ toNanoSecs time) * 1.0e9) diff --git a/src/Serokell/Util/Binary.hs b/src/Serokell/Util/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Binary.hs @@ -0,0 +1,17 @@ +-- | Utilities for @Data.Binary@. + +module Serokell.Util.Binary + ( decodeFull + ) where + +import Data.Binary (Binary, decodeOrFail) +import qualified Data.ByteString.Lazy as BSL +import Data.ByteString.Lazy (ByteString) + +-- | Like 'decode', but ensures that the whole input has been consumed. +decodeFull :: Binary a => ByteString -> Either String a +decodeFull bs = case decodeOrFail bs of + Left (_, _, err) -> Left ("decodeFull: " ++ err) + Right (unconsumed, _, a) + | BSL.null unconsumed -> Right a + | otherwise -> Left "decodeFull: unconsumed input" diff --git a/src/Serokell/Util/Common.hs b/src/Serokell/Util/Common.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Common.hs @@ -0,0 +1,72 @@ +-- | Common utilities. + +module Serokell.Util.Common + ( enumerate + , indexModulo + , indexModuloMay + , indexedSubList + , subList + ) where + +import Control.Monad.State (evalState, get, modify) +import Data.List (genericDrop, genericIndex, genericLength, + genericTake) +import Data.Maybe (fromMaybe) + +-- | Enumerate function is analogous to python's enumerate. It +-- takes sequences of values and returns sequence of pairs where the +-- first element is index and the second one is corresponding value. +-- It's roughly equivalent to `zip [0..]`. +-- > enumerate "Hello" = [(0,'H'),(1,'e'),(2,'l'),(3,'l'),(4,'o')] +enumerate + :: (Num i, Enum i, Traversable t) + => t a -> t (i, a) +enumerate values = evalState action 0 + where + action = mapM step values + step v = do + i <- get + modify succ + return (i, v) + +-- | Returns element of a list with given index modulo length of +-- list. Raises error if list is empty. +-- Examples: +-- indexModulo [1, 2, 3] 10 = 2 +-- indexModulo [1, 0] 2 = 1 +-- indexModulo [] 199 = error +indexModulo :: Integral i => [a] -> i -> a +indexModulo xs = + fromMaybe (error "Serokell.Util.Common.indexModulo: empty list") . + indexModuloMay xs + +-- | Behaves like `indexModulo` but uses Maybe to report error +-- (i. e. empty list). +indexModuloMay :: Integral i => [a] -> i -> Maybe a +indexModuloMay xs i = genericIndex xs <$> indexModuloIndex xs i + +indexModuloIndex :: Integral i => [a] -> i -> Maybe i +indexModuloIndex [] _ = Nothing +indexModuloIndex xs i = Just $ i `mod` genericLength xs + +-- | indexedSubList (lo, hi) returns sublist of given list with +-- indices in [max lo 0, hi). If the lower bound is negative, +-- 0 will in its place. If both indices are negative, the empty list +-- is returned. +-- Examples: +-- indexedSubList (2, 3) [0, 5, 10] = [(2, 10)] +-- indexedSubList (0, 2) [0, 5, 10] = [(0, 0), (1, 5)] +-- indexedSubList (0, 0) [0, 1, 11, 111] = [] +-- indexedSubList (2000, 1000) [55, 47, 0, 1, 11, 111] = [] +-- indexedSubList (-3, 3) [10, 11, 12, 13, 14] = [(0,10),(1,11),(2,12)] +-- indexedSubList (-6, -1) [1,2,3] = [] +indexedSubList + :: Integral i + => (i, i) -> [a] -> [(i, a)] +indexedSubList (lo, hi) + | hi <= lo = const [] + | otherwise = zip [max 0 lo .. hi - 1] . genericTake (hi - lo) . genericDrop lo + +-- | Like indexedSubList, but not indexed :) +subList :: Integral i => (i, i) -> [a] -> [a] +subList range = map snd . indexedSubList range diff --git a/src/Serokell/Util/Concurrent.hs b/src/Serokell/Util/Concurrent.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Concurrent.hs @@ -0,0 +1,14 @@ +-- | Convenient versions of some functions from `Control.Concurrent` + +module Serokell.Util.Concurrent + ( threadDelay + ) where + +import qualified Control.Concurrent as Concurrent +import Control.Monad.Trans (MonadIO (liftIO)) +import Data.Time.Units (TimeUnit (toMicroseconds)) + +-- | Convenient version of Control.Concurrent.threadDelay which takes +-- any time-unit and operates in any MonadIO +threadDelay :: (MonadIO m, TimeUnit unit) => unit -> m () +threadDelay = liftIO . Concurrent.threadDelay . fromIntegral . toMicroseconds diff --git a/src/Serokell/Util/Exceptions.hs b/src/Serokell/Util/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Exceptions.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Bitgram's general-purpose exceptions. +-- They may be useful when you need a simple instance of Exception (e. g. in MonadThrow context) + +module Serokell.Util.Exceptions + ( TextException (..) + , throwText + , EmptyException (..) + , throwEmpty + , eitherToFail + ) where + +import Control.Exception (Exception, SomeException, + fromException) +import Control.Monad.Catch (MonadThrow, throwM) +import Data.Text (Text) +import Data.Text.Buildable (Buildable (build)) +import qualified Data.Text.Format as F +import Data.Text.Lazy.Builder (Builder) +import Data.Typeable (Typeable) + +instance Buildable SomeException where + build e = + maybe (build $ F.Shown e) (build :: TextException -> Builder) $ + fromException e + +-- | Use this type if you are sure that text description is enough to represent error +newtype TextException = TextException + { teMessage :: Text + } deriving (Show,Typeable) + +instance Exception TextException + +instance Buildable TextException where + build = F.build "TextException: {}" . F.Only . teMessage + +throwText :: MonadThrow m + => Text -> m a +throwText = throwM . TextException + +-- | Use this type if you want to signal about error and there may be only one reason for it +data EmptyException = EmptyException + deriving (Show, Typeable) + +instance Exception EmptyException + +throwEmpty :: MonadThrow m => m a +throwEmpty = throwM EmptyException + +-- | Convert MonadThrow to arbitrary monad using `fail` to report +-- error Useful when you have `MonadThrow` and want to use it in +-- another monad context which uses `fail` for errors +eitherToFail :: (Monad m, e ~ SomeException) => Either e a -> m a +eitherToFail = either (fail . show) return diff --git a/src/Serokell/Util/I18N.hs b/src/Serokell/Util/I18N.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/I18N.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + +module Serokell.Util.I18N + ( Translations + , fromYaml + , replaceTranslations + , YamlMapKey + , ToReplaceToken(..) + ) where + +import Data.Aeson.Extra.Map (FromJSONKey (..), getMap) +import Data.Aeson.Types (genericParseJSON, genericToJSON) +import qualified Data.Aeson.Types as AT +import Data.ByteString as BS +import qualified Data.Map.Strict as M +import Data.Text as T +import Data.Yaml (decodeEither) +import Formatting (build, sformat, (%)) +import GHC.Generics (Generic, Rep) +import Serokell.Aeson.Options (defaultOptions) + +class (Eq a, Ord a, FromJSONKey a) => YamlMapKey a + +instance (Generic a, AT.GFromJSON (Rep a)) => + FromJSONKey a where + parseJSONKey l = genericParseJSON defaultOptions (AT.String l) + +instance (Eq a, Ord a, Generic a, AT.GFromJSON (Rep a)) => + YamlMapKey a + +type Translations lang token = M.Map lang (M.Map token T.Text) + +fromYaml :: (YamlMapKey lang, YamlMapKey token) + => BS.ByteString + -> Translations lang token +fromYaml yamlStr = + toLangMap $ + either + (error . + T.unpack . sformat ("Error during translation YAML parsing " % build)) + id $ + decodeEither yamlStr + where + toLangMap = fmap getMap . getMap + + +class (Ord a, Eq a) => ToReplaceToken a where + toReplaceToken :: a -> T.Text + +instance (Ord a, Eq a, Generic a, AT.GToJSON (Rep a)) => ToReplaceToken a where + toReplaceToken = (\(AT.String s) -> s) . genericToJSON defaultOptions + +replaceTranslations + :: (ToReplaceToken token, Eq lang, Ord lang) + => Translations lang token -> lang -> T.Text -> Maybe T.Text +replaceTranslations translations lang text = + M.foldrWithKey + (\token -> + T.replace $ "{{" `T.append` toReplaceToken token `T.append` "}}") + text <$> + lang `M.lookup` translations diff --git a/src/Serokell/Util/Lens.hs b/src/Serokell/Util/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Lens.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE Rank2Types #-} + +-- | Extra operators on Lens +module Serokell.Util.Lens + ( (%%=) + , (%?=) + ) where + +import qualified Control.Lens as L +import Control.Monad.State (State, get, runState) +import Control.Monad.Trans.Except (ExceptT, mapExceptT) + +-- I don't know how to call these operators + +-- | Similar to %= operator, but takes State action instead of (a -> a) +infix 4 %%= +(%%=) :: L.Lens' s a -> State a b -> State s b +(%%=) l ma = do + attr <- L.view l <$> get + let (res,newAttr) = runState ma attr + l L..= newAttr + return res + +-- | Like %%= but with possiblity of failure +infix 4 %?= +(%?=) :: L.Lens' s a -> ExceptT t (State a) b -> ExceptT t (State s) b +(%?=) l = mapExceptT (l %%=) diff --git a/src/Serokell/Util/OptParse.hs b/src/Serokell/Util/OptParse.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/OptParse.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Some useful helper for optparse-applicative library + +module Serokell.Util.OptParse + ( fromStr + , strArgument + , strOption + , fromParsec + ) where + +import Data.String (IsString (fromString)) +import Options.Applicative (ArgumentFields, Mod, OptionFields, Parser, ReadM, + argument, eitherReader, option, str) +import Text.Parsec (Parsec, parse) + +-- | Reader which uses IsString instance for parsing +fromStr :: IsString s => ReadM s +fromStr = fromString <$> str + +-- | Parse argument using IsString instance +strArgument :: IsString s => Mod ArgumentFields s -> Parser s +strArgument = argument fromStr + +-- | Parse option using IsString instance +strOption :: IsString s => Mod OptionFields s -> Parser s +strOption = option fromStr + +fromParsec :: Parsec String () a -> ReadM a +fromParsec parser = eitherReader $ either (Left . show) Right . parse parser "" diff --git a/src/Serokell/Util/Parse.hs b/src/Serokell/Util/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Parse.hs @@ -0,0 +1,9 @@ +-- | Some useful helpers for parsec library + +module Serokell.Util.Parse + ( module Export + ) where + +import Serokell.Util.Parse.Base64 as Export +import Serokell.Util.Parse.Common as Export +import Serokell.Util.Parse.Network as Export diff --git a/src/Serokell/Util/Parse/Base64.hs b/src/Serokell/Util/Parse/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Parse/Base64.hs @@ -0,0 +1,27 @@ +-- | Parsing Base64 + +module Serokell.Util.Parse.Base64 + ( base64 + , base64Url + ) where +import qualified Data.ByteString as BS +import Data.Text (pack, unpack) +import Serokell.Util.Base64 (decode, decodeUrl) +import Serokell.Util.Parse.Common (Parser, asciiAlphaNum) +import Text.Parsec (many, many1, (<|>)) +import Text.ParserCombinators.Parsec.Char (char) + +base64 :: Parser BS.ByteString +base64 = do + str <- (++) <$> many1 (asciiAlphaNum <|> char '+' <|> char '/') <*> many (char '=') + case decode $ pack str of + Left e -> fail $ unpack e + Right bs -> return bs + +base64Url :: Parser BS.ByteString +base64Url = do + str <- (++) <$> many1 (asciiAlphaNum <|> char '_' <|> char '-') <*> many (char '=') + case decodeUrl $ pack str of + Left e -> fail $ unpack e + Right bs -> return bs + diff --git a/src/Serokell/Util/Parse/Common.hs b/src/Serokell/Util/Parse/Common.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Parse/Common.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | Parsing common helpers + +module Serokell.Util.Parse.Common + ( Parser + , countMinMax + , limitedInt + , byte + , asciiAlphaNum + ) where + +import Text.Parsec (Parsec, ParsecT, Stream, option, + satisfy) +import Text.ParserCombinators.Parsec.Char (digit) + +type Parser = Parsec String () + +isAsciiAlpha :: Char -> Bool +isAsciiAlpha c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') + +isAsciiNum :: Char -> Bool +isAsciiNum c = (c >= '0' && c <= '9') + +isAsciiAlphaNum :: Char -> Bool +isAsciiAlphaNum c = isAsciiAlpha c || isAsciiNum c + +asciiAlphaNum :: Parser Char +asciiAlphaNum = satisfy isAsciiAlphaNum + +countMinMax :: (Stream s m t) => Int -> Int -> ParsecT s u m a -> ParsecT s u m [a] +countMinMax m x p + | m > 0 = do + f <- p + end <- countMinMax (m - 1) (x - 1) p + return $ f : end + | x <= 0 = return [] + | otherwise = option [] $ do + f <- p + end <- countMinMax 0 (x - 1) p + return $ f : end + +limitedInt :: Int -> String -> Parser Int +limitedInt x e = do + b <- read <$> countMinMax 1 (intDigits x) digit + if b > x + then fail e + else return b + where + intDigits = length . show + +byte :: Parser Word +byte = fromIntegral <$> limitedInt 255 "Value to large" + diff --git a/src/Serokell/Util/Parse/Network.hs b/src/Serokell/Util/Parse/Network.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Parse/Network.hs @@ -0,0 +1,117 @@ +-- | Parsing network data + +module Serokell.Util.Parse.Network + ( Host (..) + , port + , ipv4address + , ipv6address + , ipv6addressWithScope + , hostname + , host + , host' + , connection + , connection' + ) where + +import Control.Monad (liftM, void) +import Data.Word (Word16) +import Serokell.Util.Parse.Common (Parser, asciiAlphaNum, byte, + countMinMax, limitedInt) +import Text.Parsec (choice, count, many1, oneOf, option, + try, (), (<|>)) +import Text.ParserCombinators.Parsec.Char (alphaNum, char, hexDigit, string) + +data Host = IPv4Address { hostAddress :: String } + | IPv6Address { hostAddress :: String } + | HostName { hostAddress :: String } + deriving(Show, Eq, Ord) + +concatSequence :: (Monad m) => [m [a]] -> m [a] +concatSequence = liftM concat . sequence + +port :: Parser Word16 +port = fromIntegral <$> limitedInt 65535 "Port number to large" + +ipv4address :: Parser String +ipv4address = concatSequence [ + byteStr, string ".", + byteStr, string ".", + byteStr, string ".", byteStr] "bad IPv4 address" + where + byteStr = show <$> byte + +ipv6address :: Parser String +ipv6address = do + let ipv6variants = (try <$> skippedAtBegin) + ++ [try full] + ++ (try <$> skippedAtMiddle) + ++ (try <$> skippedAtEnd) + ++ [last2 False] + choice ipv6variants "bad IPv6 address" + where + hexShortNum = countMinMax 1 4 hexDigit + h4s = (++) <$> hexShortNum <*> string ":" + sh4 = (++) <$> string ":" <*> hexShortNum + execNum 0 = return "" + execNum n = concat <$> count n h4s + partNum 0 = return "" + partNum n = do + f <- hexShortNum + e <- countMinMax 0 (n - 1) (try sh4) + return $ f ++ concat e + + maybeNum n = concat <$> countMinMax 0 n h4s + last2f = try ipv4address <|> concatSequence [h4s, hexShortNum] + last2 f = if f + then last2f + else choice [try last2f, + try $ concatSequence [string "::", hexShortNum], + concatSequence [hexShortNum, string "::"]] + + skippedAtBegin = + map (\i -> concatSequence [string "::", execNum i, last2 True]) [5,4..0] + + skippedAtMiddle = [ + concatSequence [partNum 1, string "::", maybeNum 4, last2 True], + concatSequence [partNum 2, string "::", maybeNum 3, last2 True], + concatSequence [partNum 3, string "::", maybeNum 2, last2 True], + concatSequence [partNum 4, string "::", maybeNum 1, last2 True], + concatSequence [partNum 5, string "::", last2 True], + concatSequence [partNum 6, string "::", hexShortNum]] + + skippedAtEnd = [concatSequence [partNum 7, string "::"]] + + full = concatSequence [concat <$> count 6 h4s, last2 True] + +ipv6addressWithScope :: Parser String +ipv6addressWithScope = concatSequence [ipv6address, option "" scope] + where + scope = concatSequence [string "%", many1 asciiAlphaNum] + +hostname :: Parser String +hostname = many1 $ alphaNum <|> oneOf ".-_" + +host :: Parser String +host = hostAddress <$> host' + +host' :: Parser Host +host' = (IPv6Address <$> try ipv6str) + <|> (IPv4Address <$> try ipv4address) + <|> (HostName <$> hostname) + where + ipv6str = do + void $ char '[' + ipv6 <- ipv6addressWithScope + void $ char ']' + return ipv6 + +connection :: Parser (String, Maybe Word16) +connection = (\(h, p) -> (hostAddress h, p)) <$> connection' + +connection' :: Parser (Host, Maybe Word16) +connection' = do + addr <- host' + p <- maybePort + return (addr, p) + where + maybePort = option Nothing $ char ':' >> Just <$> port diff --git a/src/Serokell/Util/StaticAssert.hs b/src/Serokell/Util/StaticAssert.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/StaticAssert.hs @@ -0,0 +1,14 @@ +-- | Compile time assertions +-- Very simple implementation from: http://stackoverflow.com/a/6654903 +-- TODO: understand and maybe improve +module Serokell.Util.StaticAssert + ( staticAssert + ) where + +import Control.Monad (unless) +import Language.Haskell.TH (Q) + +staticAssert :: Bool -> String -> Q [a] +staticAssert cond mesg = do + unless cond $ fail $ "Compile time assertion failed: " ++ mesg + return [] -- No need to make a dummy declaration diff --git a/src/Serokell/Util/Text.hs b/src/Serokell/Util/Text.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Text.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE GADTs #-} + +-- | Utility functions to work with `text` and `text-format`. Feel +-- free to add more if you need. Some functions have two versions, `'` +-- suffix means that function operates on strict Text. + +module Serokell.Util.Text + ( -- * @formatting@ utilities + show + , show' + , FPFormat (..) + , showFloat + , showFloat' + , showFixedPretty' + , showDecimal + , showDecimal' + + -- * Formatters + , pairF + , tripleF + , listJson + , listJsonIndent + , listCsv + , mapJson + + -- * Builders + , pairBuilder + , tripleBuilder + , listBuilder + , listBuilderJSON + , listBuilderJSONIndent + , listBuilderCSV + , mapBuilder + , mapBuilderJson + + -- * @text-format@ utilities + , format + , format' + , formatSingle + , formatSingle' + , buildSingle + + -- * String readers + , readFractional + , readDouble + , readDecimal + , readUnsignedDecimal + ) where + +import qualified Data.Text as T +import Data.Text.Buildable (Buildable (build)) +import qualified Data.Text.Format as F +import Data.Text.Format.Params (Params) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.Builder.Int as B +import Data.Text.Lazy.Builder.RealFloat (FPFormat (Exponent, Fixed, Generic)) +import qualified Data.Text.Lazy.Builder.RealFloat as B +import qualified Data.Text.Read as T +import Formatting (fixed, sformat, later, Format) +import GHC.Exts (IsList(..)) +import Prelude hiding (show, showList) + +show :: Buildable a + => a -> LT.Text +show = B.toLazyText . build + +show' :: Buildable a + => a -> T.Text +show' = LT.toStrict . show + +-- | Render a floating point number using normal notation, with the +-- given number of decimal places. This function also truncates +-- redundant terminating zeros. +showFixedPretty' + :: Real a + => Int -> a -> T.Text +showFixedPretty' prec = + T.dropWhileEnd (== '.') . T.dropWhileEnd (== '0') . sformat (fixed prec) + +showFloat + :: (RealFloat a) + => FPFormat -> Maybe Int -> a -> LT.Text +showFloat f precision v = B.toLazyText $ B.formatRealFloat f precision v + +showFloat' + :: (RealFloat a) + => FPFormat -> Maybe Int -> a -> T.Text +showFloat' f prec = LT.toStrict . showFloat f prec + +showDecimal :: (Integral a) + => a -> LT.Text +showDecimal = B.toLazyText . B.decimal + +showDecimal' :: (Integral a) + => a -> T.Text +showDecimal' = LT.toStrict . showDecimal + +pairF :: (Buildable a, Buildable b) => Format r ((a,b) -> r) +pairF = later pairBuilder + +tripleF :: (Buildable a, Buildable b, Buildable c) => Format r ((a,b,c) -> r) +tripleF = later tripleBuilder + +listJson :: (Foldable t, Buildable a) => Format r (t a -> r) +listJson = later listBuilderJSON + +listJsonIndent :: (Foldable t, Buildable a) => Word -> Format r (t a -> r) +listJsonIndent = later . listBuilderJSONIndent + +listCsv :: (Foldable t, Buildable a) => Format r (t a -> r) +listCsv = later listBuilderCSV + +mapJson :: (IsList t, Item t ~ (k, v), Buildable k, Buildable v) + => Format r (t -> r) +mapJson = later mapBuilderJson + +-- | Prints pair (a, b) like "(a, b)" +pairBuilder + :: (Buildable a, Buildable b) + => (a, b) -> B.Builder +pairBuilder = F.build "({}, {})" + +-- | Prints triple (a, b, c) like "(a, b, c)" +tripleBuilder + :: (Buildable a, Buildable b, Buildable c) + => (a, b, c) -> B.Builder +tripleBuilder = F.build "({}, {}, {})" + +-- | Generic list builder. Prints prefix, then values separated by delimiter and finally suffix +listBuilder + :: (Buildable prefix, Buildable delimiter, Buildable suffix, Foldable t, Buildable a) + => prefix -> delimiter -> suffix -> t a -> B.Builder +listBuilder prefix delimiter suffix as = + mconcat [build prefix, mconcat builders, build suffix] + where builders = foldr appendBuilder [] as + appendBuilder a [] = [build a] + appendBuilder a bs = build a : build delimiter : bs + +-- | This function helps to deduce type arising from string literal +_listBuilder + :: (Foldable t, Buildable a) + => B.Builder -> B.Builder -> B.Builder -> t a -> B.Builder +_listBuilder = listBuilder + +-- | Prints values in JSON-style (e. g. `[111, ololo, blablabla]`) +listBuilderJSON + :: (Foldable t, Buildable a) + => t a -> B.Builder +listBuilderJSON = _listBuilder "[" ", " "]" + +-- | Like listBuilderJSON, but prints each value on a new line with indentation +listBuilderJSONIndent + :: (Foldable t, Buildable a) + => Word -> t a -> B.Builder +listBuilderJSONIndent _ as | null as = "[]" +listBuilderJSONIndent indent as + | otherwise = + listBuilder ("[\n" `LT.append` spaces) + delimiter + ("\n]" :: B.Builder) + as + where spaces = + LT.replicate (fromIntegral indent) + " " + delimiter = ",\n" `LT.append` spaces + +-- | Prints comma separated values +listBuilderCSV + :: (Foldable t, Buildable a) + => t a -> B.Builder +listBuilderCSV = _listBuilder "" "," "" + +-- | There is no appropriate type class for map, but all reasonable maps +-- provide something like `assocs` function. +-- Map may be printed prettier (e. g. using JSON style), it's future task. +-- Having at least one such function is still good anyway. +mapBuilder + :: (Traversable t, Buildable k, Buildable v) + => t (k, v) -> B.Builder +mapBuilder = listBuilderJSON . fmap pairBuilder + +mapBuilderJson + :: (IsList t, Item t ~ (k, v), Buildable k, Buildable v) + => t -> B.Builder +mapBuilderJson = _listBuilder "{" ", " "}" . map (F.build "{}: {}") . toList + +{-# DEPRECATED format, format', formatSingle, formatSingle' "Not typesafe. Use formatting library instead" #-} + +-- | Re-export Data.Text.Format.format for convenience +format :: Params ps + => F.Format -> ps -> LT.Text +format = F.format + +-- | Version of Data.Text.Format.format which returns strict Text +format' :: Params ps + => F.Format -> ps -> T.Text +format' f = LT.toStrict . F.format f + +formatSingle :: Buildable a + => F.Format -> a -> LT.Text +formatSingle f = format f . F.Only + +formatSingle' :: Buildable a + => F.Format -> a -> T.Text +formatSingle' f = LT.toStrict . formatSingle f + +buildSingle :: Buildable a + => F.Format -> a -> B.Builder +buildSingle f = F.build f . F.Only + +-- | Read fractional number. Returns error (i. e. Left) if there is something else +readFractional :: Fractional a => T.Text -> Either String a +readFractional = _wrapReader T.rational + +-- | Like readFractional, but much more efficient. It may be slightly less accurate +readDouble :: T.Text -> Either String Double +readDouble = _wrapReader T.double + +-- | Read signed decimal number. Returns error (i. e. Left) if there is something else +-- WARNING: if input is negative and `a` is unsigned, overflow will occur +readDecimal :: Integral a => T.Text -> Either String a +readDecimal = _wrapReader $ T.signed T.decimal + +-- | Read unsigned decimal number. Returns error (i. e. Left) if there is something else +readUnsignedDecimal :: Integral a => T.Text -> Either String a +readUnsignedDecimal = _wrapReader T.decimal + +_wrapReader :: T.Reader a -> T.Text -> Either String a +_wrapReader reader t = + case reader t of + Left err -> Left $ mconcat [ "failed to parse '" + , T.unpack t + , "': " + , err + ] + Right (res, "") -> Right res + Right (_, remainder) -> + Left $ + mconcat [ "failed to parse '" + , T.unpack t + , "', because there is a remainder: " + , T.unpack remainder + ] diff --git a/src/Serokell/Util/Verify.hs b/src/Serokell/Util/Verify.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Verify.hs @@ -0,0 +1,52 @@ +-- | General-purpose utility functions + +module Serokell.Util.Verify + ( VerificationRes (..) + , isVerFailure + , isVerSuccess + + , verifyGeneric + ) where + +import Data.Semigroup (Semigroup) +import qualified Data.Semigroup as Semigroup +import qualified Data.Text as T + +data VerificationRes + = VerSuccess + | VerFailure ![T.Text] + deriving (Show) + +isVerSuccess :: VerificationRes -> Bool +isVerSuccess VerSuccess = True +isVerSuccess _ = False + +isVerFailure :: VerificationRes -> Bool +isVerFailure (VerFailure _) = True +isVerFailure _ = False + +instance Semigroup VerificationRes where + VerSuccess <> a = a + VerFailure xs <> a = + VerFailure $ + xs ++ + case a of + VerSuccess -> [] + VerFailure ys -> ys + +instance Monoid VerificationRes where + mempty = VerSuccess + mappend = (Semigroup.<>) + +-- | This function takes list of (predicate, message) pairs and checks +-- each predicate. If predicate is False it's considered an error. +-- If there is at least one error this function returns VerFailure, +-- otherwise VerSuccess is returned. It's useful to verify some data +-- before using it. +-- Example usage: `verifyGeneric [(checkA, "A is bad"), (checkB, "B is bad")]` +verifyGeneric :: [(Bool, T.Text)] -> VerificationRes +verifyGeneric errors + | null messages = VerSuccess + | otherwise = VerFailure messages + where + messages = map snd . filter (not . fst) $ errors 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 -optF --module-name=Spec #-} diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,5 @@ +import Spec (spec) +import Test.Hspec (hspec) + +main :: IO () +main = hspec spec diff --git a/test/Test/Serokell/Data/Memory/UnitsSpec.hs b/test/Test/Serokell/Data/Memory/UnitsSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Data/Memory/UnitsSpec.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Test.Serokell.Data.Memory.UnitsSpec + ( spec + ) where + +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) + +import Serokell.Arbitrary () +import qualified Serokell.Data.Memory.Units as S + +spec :: Spec +spec = describe "Unit conversion" $ do + describe "Identity Properties" $ do + prop "Byte" $ + \(a :: S.Byte) -> a === bytesMid a + prop "Kilobyte" $ + \(a :: S.Kilobyte) -> a === bytesMid a + prop "Megabyte" $ + \(a :: S.Megabyte) -> a === bytesMid a + prop "Gigabyte" $ + \(a :: S.Gigabyte) -> a === bytesMid a + prop "Terabyte" $ + \(a :: S.Terabyte) -> a === bytesMid a + +bytesMid :: forall u. S.MemoryUnit u => u -> u +bytesMid = S.convertUnit diff --git a/test/Test/Serokell/Data/Variant/VariantSpec.hs b/test/Test/Serokell/Data/Variant/VariantSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Data/Variant/VariantSpec.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Serokell.Data.Variant.VariantSpec + ( spec + ) where + +import qualified Data.Aeson as A (decode, encode) +import qualified Data.Binary as B (decode, encode) +import qualified Data.HashMap.Lazy as HM (elems, fromList, keys) +import Data.MessagePack (fromObject, toObject) +import qualified Data.SafeCopy as SC (safeGet, safePut) +import Data.Scientific (floatingOrInteger, fromFloatDigits) +import qualified Data.Serialize as C (decode, encode, runGet, runPut) +import Data.Text (unpack) +import qualified Data.Vector as V (map) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) + +import Serokell.Arbitrary (VariantNoBytes (..), + VariantOnlyBytes (..)) +import qualified Serokell.Data.Variant as S +import qualified Serokell.Util.Base64 as S +import Serokell.Util.Text (show') + +spec :: Spec +spec = describe "Variant" $ do + describe "Identity Properties" $ do + describe "JSON" $ do + prop "Variant (No VarBytes)" $ + \(getVariant -> a) -> (jsonFixer a) === jsonMid a + prop "Variant (Only VarBytes)" $ + \(getVarBytes -> a) -> a === (bytesFun $ jsonMid a) + prop "MessagePack" $ + \(a :: S.Variant) -> (msgPkFixer a) === msgPkMid a + prop "Binary" $ + \(a :: S.Variant) -> a === binMid a + prop "SafeCopy" $ + \(a :: S.Variant) -> a === safeCopyMid a + prop "Serialize" $ + \(a :: S.Variant) -> a === cerealMid a + +jsonFixer :: S.Variant -> S.Variant +jsonFixer (S.VarMap m) = let ks = map toStr $ HM.keys m + vs = map jsonFixer $ HM.elems m + m' = HM.fromList $ zip ks vs + in S.VarMap m' +jsonFixer (S.VarList l) = S.VarList $ V.map jsonFixer l +jsonFixer v@(S.VarInt i) = + if i < 0 then v + else (S.VarUInt $ fromIntegral i) +jsonFixer (S.VarFloat f) = + case floatingOrInteger $ fromFloatDigits f of + Left float -> S.VarFloat float + Right int -> if int < 0 then S.VarInt int + else S.VarUInt $ fromIntegral int +jsonFixer v = v + +toStr :: S.Variant -> S.Variant +toStr var = stringVar var + where + stringVar :: S.Variant -> S.Variant + stringVar = S.VarString . show' + +jsonMid :: S.Variant -> S.Variant +jsonMid = maybe err id . A.decode . A.encode + where + err = error "[VariantSpec] Failed JSON decoding" + +bytesFun :: S.Variant -> S.Variant +bytesFun (S.VarString s) = S.VarBytes right + where + right = either (error . unpack) id $ S.decode s +bytesFun _ = error "[bytesFun:] called with Variant that was not VarBytes" + +msgPkFixer :: S.Variant -> S.Variant +msgPkFixer (S.VarMap m) = let ks = map msgPkFixer $ HM.keys m + vs = map msgPkFixer $ HM.elems m + m' = HM.fromList $ zip ks vs + in S.VarMap m' +msgPkFixer (S.VarList l) = S.VarList $ V.map msgPkFixer l +msgPkFixer v@(S.VarInt i) = + if i < 0 then v + else (S.VarUInt $ fromIntegral i) +msgPkFixer v@(S.VarUInt i) = + if i >= 0 then v + else (S.VarInt $ fromIntegral i) +msgPkFixer v = v + +msgPkMid :: S.Variant -> S.Variant +msgPkMid = maybe err id . fromObject . toObject + where + err = error "[VariantSpec] Failed MessagePack decoding" + +binMid :: S.Variant -> S.Variant +binMid = B.decode . B.encode + +cerealMid :: S.Variant -> S.Variant +cerealMid = either error id . C.decode . C.encode + +safeCopyMid :: S.Variant -> S.Variant +safeCopyMid = either error id . C.runGet SC.safeGet . C.runPut . SC.safePut diff --git a/test/Test/Serokell/Util/ByteStringSpec.hs b/test/Test/Serokell/Util/ByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Util/ByteStringSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Test.Serokell.Util.ByteStringSpec + ( spec + ) where + +import Data.Aeson (decode, encode) +import qualified Data.ByteString as BS +import Data.Maybe (fromJust) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) +import Test.QuickCheck.Instances () + +import Serokell.Arbitrary () +import qualified Serokell.Util.Base16 as C16 +import qualified Serokell.Util.Base64 as C64 + +deriving instance Eq C64.JsonByteString +deriving instance Show C64.JsonByteString + +spec :: Spec +spec = + describe "Serialization" $ do + describe "Indentity Properties" $ do + prop "Base16" $ + \(a :: BS.ByteString) -> a === base16Mid a + prop "Base64" $ + \(a :: BS.ByteString) -> a === base64Mid a + prop "JSON Base64" $ + \(a :: C64.JsonByteString) -> a === base64JSONMid a + +base16Mid, + base64Mid :: BS.ByteString -> BS.ByteString +base16Mid = fromRight . C16.decode . C16.encode +base64Mid = fromRight . C64.decode . C64.encode + +base64JSONMid :: C64.JsonByteString -> C64.JsonByteString +base64JSONMid = fromJust . decode . encode + +fromRight :: Either a BS.ByteString -> BS.ByteString +fromRight (Left _) = error "failed decoding to ByteString" +fromRight (Right b) = b diff --git a/test/Test/Serokell/Util/CommonSpec.hs b/test/Test/Serokell/Util/CommonSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Util/CommonSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Serokell.Util.CommonSpec + ( spec + ) where + +import Data.Foldable (toList) +import Data.List (genericIndex, genericLength, + intersect) +import Data.Vector (Vector) +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck (Arbitrary (..), Gen, + NonEmptyList (..), oneof) +import Test.QuickCheck.Instances () + +import qualified Serokell.Util.Common as C + +spec :: Spec +spec = + describe "Common" $ do + describe "enumerate" $ + prop description_enumerateCheck enumerateCheckIndexes + describe "indexModulo" $ + prop description_indexModulo indexModuloCorrectIndex + describe "indexedSubList" $ + prop description_indexedSubListNeg indexedSublistWhenNegative + where + description_enumerateCheck = + "enumerates a structure in sequence, " ++ + "starting from index 0" + description_indexModulo = + "returns the element of the the list with " ++ + "given index modulo length of the list" + description_indexedSubListNeg = + "negative indices, given that the lower " ++ + "bound is lesser than the upper bound, result in valid indexation" + +-- TODO: consider using `SomeValue` to generate different types of +-- values. I don't know how to add more than one quantifier to type +-- definition. Also consider using GADTs to achieve it. +type Value = Int + +data SomeTraversable = + forall t. (Traversable t, Show (t Value), Arbitrary (t Value)) => + SomeTraversable (t Value) + +instance Show SomeTraversable where + show (SomeTraversable t) = show t + +instance Arbitrary SomeTraversable where + arbitrary = + oneof + [ SomeTraversable <$> (arbitrary :: Gen [Value]) + , SomeTraversable <$> (arbitrary :: Gen (Vector Value)) + ] + +enumerateCheckIndexes :: SomeTraversable -> Bool +enumerateCheckIndexes (SomeTraversable values) = + let indexedVals = C.enumerate values + indexList = toList $ fmap fst indexedVals + indexNum = genericLength indexList + in null values || indexList == [0 :: Word .. indexNum-1] + +indexModuloCorrectIndex + :: NonEmptyList Int -> Int -> Bool +indexModuloCorrectIndex (getNonEmpty -> list) ind = + let len = genericLength list + atModuloIndex = list `genericIndex` (ind `mod` len) + in atModuloIndex == C.indexModulo list ind + +indexedSublistWhenNegative + :: (Int, Int) -> [Int] -> Bool +indexedSublistWhenNegative (lo, hi) list + | hi <= lo = indexList lo hi == [] + | hi <= 0 = indexList lo hi == [] + | len -1 < lo = indexList lo hi == [] + | otherwise = testIndexes lo hi == indexList lo hi + where + len = length list + indexList l h = map fst $ C.indexedSubList (l, h) list + testIndexes l h = intersect [l .. h - 1] [0 .. len - 1] diff --git a/test/Test/Serokell/Util/TextSpec.hs b/test/Test/Serokell/Util/TextSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Serokell/Util/TextSpec.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Test.Serokell.Util.TextSpec + ( spec + ) where + +import Data.Int (Int64) +import Data.Text.Buildable (Buildable) +import Data.Word (Word64) + +import Test.Hspec (Spec, describe) +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck ((===)) +import Test.QuickCheck.Instances () + +import qualified Serokell.Util.Text as S + +spec :: Spec +spec = + describe "Text Show/Read" $ do + describe "Indentity Properties" $ do + describe "readDecimal" $ do + prop "Int" $ + \(a :: Int) -> (Right a) === showReadIntegral a + prop "Integer" $ + \(a :: Integer) -> (Right a) === showReadIntegral a + prop "Word" $ + \(a :: Word) -> (Right a) === showReadIntegral a + prop "Int64" $ + \(a :: Int64) -> (Right a) === showReadIntegral a + prop "Word64" $ + \(a :: Word64) -> (Right a) === showReadIntegral a + +showReadIntegral + :: (Buildable a, Integral a) => a -> Either String a +showReadIntegral = S.readDecimal . S.show'