diff --git a/serokell-util.cabal b/serokell-util.cabal --- a/serokell-util.cabal +++ b/serokell-util.cabal @@ -1,5 +1,5 @@ name: serokell-util -version: 0.1.3.5 +version: 0.1.4.0 synopsis: General-purpose functions by Serokell homepage: https://github.com/serokell/serokell-util license: MIT @@ -29,6 +29,7 @@ Serokell.Data.Memory.Units Serokell.Data.Variant Serokell.Util + Serokell.Util.ANSI Serokell.Util.Base Serokell.Util.Base16 Serokell.Util.Base64 @@ -43,6 +44,7 @@ Serokell.Util.Lens Serokell.Util.StaticAssert Serokell.Util.Text + Serokell.Util.Time Serokell.Util.Verify other-modules: Serokell.Data.Variant.Class Serokell.Data.Variant.Helpers @@ -53,8 +55,9 @@ Serokell.Util.Parse.Network build-depends: QuickCheck >= 2.8.1 , acid-state - , aeson >= 0.11.0.0 && < 2.0.0.0 + , aeson >= 0.11.0.0 && < 1.2.0.0 , aeson-extra >= 0.4.0.0 + , ansi-terminal , base >= 4.8 && < 5 , base16-bytestring , base64-bytestring @@ -63,8 +66,8 @@ , bytestring , cereal , cereal-vector - , containers , clock + , containers , data-msgpack >= 0.0.8 , deepseq , directory @@ -90,6 +93,7 @@ , text-format , time-units , transformers + , universum , unordered-containers >= 0.2.7.0 , vector , yaml @@ -112,7 +116,7 @@ Test.Serokell.Util.VerifySpec Spec type: exitcode-stdio-1.0 - build-depends: aeson >= 0.11.0.0 && < 2.0.0.0 + build-depends: aeson >= 0.11.0.0 && < 1.2.0.0 , base >=4.8 , binary , bytestring diff --git a/src/Serokell/AcidState/Instances.hs b/src/Serokell/AcidState/Instances.hs --- a/src/Serokell/AcidState/Instances.hs +++ b/src/Serokell/AcidState/Instances.hs @@ -1,4 +1,6 @@ --- | Helper instances for Acid State to remove boilerplate and introduce +{-# LANGUAGE CPP #-} + +-- | Helper instances for acid-state to remove boilerplate and introduce -- redundant instances for other data types. module Serokell.AcidState.Instances where @@ -6,14 +8,16 @@ import Control.Exception (throw) import Control.Monad.Catch (MonadThrow (throwM)) +import qualified Data.Time.Units as Time 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) +import qualified Data.List.NonEmpty as NE +import Data.SafeCopy (SafeCopy (..), contain, safeGet, + safePut) -- | Usually Queries shouldn't throw anything. This is a dirty hack. instance MonadThrow (Query s) where @@ -29,3 +33,39 @@ instance (Eq a, Hashable a, SafeCopy a, SafeCopy b) => SafeCopy (HashMap a b) where putCopy = contain . safePut . HM.toList getCopy = contain $ HM.fromList <$> safeGet + +-- [SRK-51]: we should try to get this one into safecopy itself though it's +-- unlikely that they will choose a different implementation (if they do +-- choose a different implementation we'll have to write a migration) +-- +-- update: made a PR ; +-- remove this instance when the pull request is merged +instance SafeCopy a => SafeCopy (NE.NonEmpty a) where + getCopy = contain $ do + xs <- safeGet + case NE.nonEmpty xs of + Nothing -> fail "getCopy@NonEmpty: list can't be empty" + Just xx -> return xx + putCopy = contain . safePut . NE.toList + errorTypeName _ = "NonEmpty" + +#define SAFECOPY_TIME(T, TS) \ + instance SafeCopy T where { \ + getCopy = contain (fromInteger <$> safeGet); \ + putCopy = contain . safePut . toInteger; \ + errorTypeName _ = TS } \ + +SAFECOPY_TIME(Time.Fortnight, "Fortnight") +SAFECOPY_TIME(Time.Week, "Week") +SAFECOPY_TIME(Time.Day, "Day") +SAFECOPY_TIME(Time.Hour, "Hour") +SAFECOPY_TIME(Time.Minute, "Minute") +SAFECOPY_TIME(Time.Second, "Second") +SAFECOPY_TIME(Time.Millisecond, "Millisecond") +SAFECOPY_TIME(Time.Microsecond, "Microsecond") +SAFECOPY_TIME(Time.Nanosecond, "Nanosecond") +SAFECOPY_TIME(Time.Picosecond, "Picosecond") +SAFECOPY_TIME(Time.Femtosecond, "Femtosecond") +SAFECOPY_TIME(Time.Attosecond, "Attosecond") + +#undef SAFECOPY_TIME diff --git a/src/Serokell/Util.hs b/src/Serokell/Util.hs --- a/src/Serokell/Util.hs +++ b/src/Serokell/Util.hs @@ -5,6 +5,7 @@ module Exports ) where +import Serokell.Util.ANSI as Exports import Serokell.Util.Bench as Exports import Serokell.Util.Binary as Exports import Serokell.Util.Common as Exports @@ -14,4 +15,5 @@ import Serokell.Util.OptParse as Exports import Serokell.Util.StaticAssert as Exports import Serokell.Util.Text as Exports +import Serokell.Util.Time as Exports import Serokell.Util.Verify as Exports diff --git a/src/Serokell/Util/ANSI.hs b/src/Serokell/Util/ANSI.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/ANSI.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Functions for working with ANSI-colored text. +module Serokell.Util.ANSI + ( Color(..) + , colorize + , withColoredMessages + ) where + +import System.Console.ANSI (Color (..), ColorIntensity (Vivid), + ConsoleLayer (Foreground), SGR (Reset, SetColor), + setSGRCode) +import Universum + +-- | Prettify 'Text' message with 'Vivid' color. +colorize :: Color -> Text -> Text +colorize color msg = + toText (setSGRCode [SetColor Foreground Vivid color]) <> + msg <> + toText (setSGRCode [Reset]) + +-- | Write colored message, do some action, write colored message. +-- Intended for debug only. +withColoredMessages :: MonadIO m => Color -> Text -> m a -> m a +withColoredMessages color activity action = do + putStrLn (colorize color ("Entered " <> activity)) + res <- action + putStrLn (colorize color ("Finished " <> activity)) + return res diff --git a/src/Serokell/Util/Common.hs b/src/Serokell/Util/Common.hs --- a/src/Serokell/Util/Common.hs +++ b/src/Serokell/Util/Common.hs @@ -6,10 +6,11 @@ , indexModuloMay , indexedSubList , subList + , allDistinct ) where import Control.Monad.State (evalState, get, modify) -import Data.List (genericDrop, genericIndex, genericLength, +import Data.List (sort, genericDrop, genericIndex, genericLength, genericTake) import Data.Maybe (fromMaybe) @@ -70,3 +71,19 @@ -- | Like indexedSubList, but not indexed :) subList :: Integral i => (i, i) -> [a] -> [a] subList range = map snd . indexedSubList range + +-- | Determine whether all elements in a list are distinct. +-- +-- >>> allDistinct [1,2,3] +-- True +-- >>> allDistinct [1,3,3] +-- False +-- +-- Naturally, all elements in an empty list are distinct: +-- +-- >>> allDistinct [] +-- True +allDistinct :: Ord a => [a] -> Bool +allDistinct xs = and $ zipWith (/=) sorted (drop 1 sorted) + where + sorted = sort xs diff --git a/src/Serokell/Util/Lens.hs b/src/Serokell/Util/Lens.hs --- a/src/Serokell/Util/Lens.hs +++ b/src/Serokell/Util/Lens.hs @@ -7,11 +7,15 @@ , (%?=) , WrappedM (..) , _UnwrappedM + , zoom' + , magnify' ) where import qualified Control.Lens as L -import Control.Monad.Reader (ReaderT) -import Control.Monad.State (State, get, runState) +import Control.Monad.Reader (MonadReader, Reader, ReaderT, reader, + runReader) +import Control.Monad.State (MonadState, State, StateT, get, runState, + state) import Control.Monad.Trans.Except (ExceptT, mapExceptT) import System.Wlog (LoggerName, LoggerNameBox (..)) @@ -50,3 +54,23 @@ instance Monad m => WrappedM (LoggerNameBox m) where type UnwrappedM (LoggerNameBox m) = ReaderT LoggerName m _WrappedM = L.iso loggerNameBoxEntry LoggerNameBox + +-- | A 'zoom' which works in arbitrary 'MonadState'. +-- +-- See . You might be surprised +-- but actual 'zoom' doesn't work in any 'MonadState', it only works in a +-- handful of state monads and their combinations defined by 'Zoom'. +zoom' + :: MonadState s m + => L.LensLike' (L.Zoomed (State s) a) s t + -> StateT t L.Identity a + -> m a +zoom' l = state . runState . L.zoom l + +-- | A 'magnify' which works in arbitrary 'MonadReader'. +magnify' + :: MonadReader s m + => L.LensLike' (L.Magnified (Reader s) a) s t + -> ReaderT t L.Identity a + -> m a +magnify' l = reader . runReader . L.magnify l diff --git a/src/Serokell/Util/Parse/Base64.hs b/src/Serokell/Util/Parse/Base64.hs --- a/src/Serokell/Util/Parse/Base64.hs +++ b/src/Serokell/Util/Parse/Base64.hs @@ -1,26 +1,29 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | 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 +import Control.Applicative (many, some, (<|>)) +import qualified Data.ByteString as BS +import Data.Text (pack, unpack) +import Serokell.Util.Base64 (decode, decodeUrl) +import Serokell.Util.Parse.Common (CharParser, asciiAlphaNum) +import Text.Parsec.Char (char) + +base64 :: CharParser BS.ByteString base64 = do - str <- (++) <$> many1 (asciiAlphaNum <|> char '+' <|> char '/') <*> many (char '=') + str <- (++) <$> some (asciiAlphaNum <|> char '+' <|> char '/') <*> many (char '=') case decode $ pack str of Left e -> fail $ unpack e Right bs -> return bs -base64Url :: Parser BS.ByteString +base64Url :: CharParser BS.ByteString base64Url = do - str <- (++) <$> many1 (asciiAlphaNum <|> char '_' <|> char '-') <*> many (char '=') + str <- (++) <$> some (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 --- a/src/Serokell/Util/Parse/Common.hs +++ b/src/Serokell/Util/Parse/Common.hs @@ -1,20 +1,23 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} -- | Parsing common helpers module Serokell.Util.Parse.Common - ( Parser + ( CharParser , countMinMax , limitedInt , byte , asciiAlphaNum + , parseIntegralSafe ) where -import Text.Parsec (Parsec, ParsecT, Stream, option, - satisfy) -import Text.ParserCombinators.Parsec.Char (digit) +import Control.Applicative (some) +import Text.Parsec (Parsec, ParsecT, Stream, option, satisfy) +import Text.Parsec.Char (digit) -type Parser = Parsec String () +type CharParser a = forall s u m. Stream s m Char => ParsecT s u m a isAsciiAlpha :: Char -> Bool isAsciiAlpha c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') @@ -25,7 +28,7 @@ isAsciiAlphaNum :: Char -> Bool isAsciiAlphaNum c = isAsciiAlpha c || isAsciiNum c -asciiAlphaNum :: Parser Char +asciiAlphaNum :: CharParser Char asciiAlphaNum = satisfy isAsciiAlphaNum countMinMax :: (Stream s m t) => Int -> Int -> ParsecT s u m a -> ParsecT s u m [a] @@ -40,7 +43,7 @@ end <- countMinMax 0 (x - 1) p return $ f : end -limitedInt :: Int -> String -> Parser Int +limitedInt :: Int -> String -> CharParser Int limitedInt x e = do b <- read <$> countMinMax 1 (intDigits x) digit if b > x @@ -49,6 +52,15 @@ where intDigits = length . show -byte :: Parser Word +byte :: CharParser Word byte = fromIntegral <$> limitedInt 255 "Value to large" +parseIntegralSafe :: Integral a => CharParser a +parseIntegralSafe = fromIntegerSafe . read =<< some digit + where + fromIntegerSafe :: Integral a => Integer -> CharParser a + fromIntegerSafe x = + let res = fromInteger x + in if fromIntegral res == x + then return res + else fail ("Number is too large: " ++ show x) diff --git a/src/Serokell/Util/Parse/Network.hs b/src/Serokell/Util/Parse/Network.hs --- a/src/Serokell/Util/Parse/Network.hs +++ b/src/Serokell/Util/Parse/Network.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} + -- | Parsing network data module Serokell.Util.Parse.Network @@ -14,14 +16,14 @@ , recipient ) where -import Control.Monad (liftM, void) -import Data.Monoid ((<>)) -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) +import Control.Applicative (some, (<|>)) +import Control.Monad (liftM, void) +import Data.Monoid ((<>)) +import Data.Word (Word16) +import Serokell.Util.Parse.Common (CharParser, asciiAlphaNum, byte, countMinMax, + limitedInt) +import Text.Parsec (choice, count, oneOf, option, try, ()) +import Text.Parsec.Char (alphaNum, char, hexDigit, string) data Host = IPv4Address { hostAddress :: String } | IPv6Address { hostAddress :: String } @@ -31,10 +33,10 @@ concatSequence :: (Monad m) => [m [a]] -> m [a] concatSequence = liftM concat . sequence -port :: Parser Word16 +port :: CharParser Word16 port = fromIntegral <$> limitedInt 65535 "Port number to large" -ipv4address :: Parser String +ipv4address :: CharParser String ipv4address = concatSequence [ byteStr, string ".", byteStr, string ".", @@ -42,7 +44,7 @@ where byteStr = show <$> byte -ipv6address :: Parser String +ipv6address :: CharParser String ipv6address = do let ipv6variants = (try <$> skippedAtBegin) ++ [try full] @@ -85,18 +87,18 @@ full = concatSequence [concat <$> count 6 h4s, last2 True] -ipv6addressWithScope :: Parser String +ipv6addressWithScope :: CharParser String ipv6addressWithScope = concatSequence [ipv6address, option "" scope] where - scope = concatSequence [string "%", many1 asciiAlphaNum] + scope = concatSequence [string "%", some asciiAlphaNum] -hostname :: Parser String -hostname = many1 $ alphaNum <|> oneOf ".-_" +hostname :: CharParser String +hostname = some $ alphaNum <|> oneOf ".-_" -host :: Parser String +host :: CharParser String host = hostAddress <$> host' -host' :: Parser Host +host' :: CharParser Host host' = (IPv6Address <$> try ipv6str) <|> (IPv4Address <$> try ipv4address) <|> (HostName <$> hostname) @@ -107,7 +109,7 @@ void $ char ']' return ipv6 -connection' :: Parser (Host, Maybe Word16) +connection' :: CharParser (Host, Maybe Word16) connection' = do addr <- host' p <- maybePort @@ -115,12 +117,12 @@ where maybePort = option Nothing $ char ':' >> Just <$> port -connection :: Parser (String, Maybe Word16) +connection :: CharParser (String, Maybe Word16) connection = (\(h, p) -> (hostAddress h, p)) <$> connection' -- | 'Parser' for host with both hostname and port. -- Example: 54.122.0.255:9999 -recipient :: Parser (String, Word16) +recipient :: CharParser (String, Word16) recipient = connection >>= \(h, mp) -> case mp of Just p -> pure (h, p) _ -> fail $ "No port specified for host " <> h diff --git a/src/Serokell/Util/Time.hs b/src/Serokell/Util/Time.hs new file mode 100644 --- /dev/null +++ b/src/Serokell/Util/Time.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Functions for working with time +module Serokell.Util.Time + ( mcs + , ms + , sec + , minute + , hour + ) where + +import Data.Time.Units (Microsecond, fromMicroseconds) +import Universum + +-- | Converts a specified time to 'Microsecond'. +mcs, ms, sec, minute, hour :: Int -> Microsecond +mcs = fromMicroseconds . fromIntegral +ms = fromMicroseconds . fromIntegral . (*) 1000 +sec = fromMicroseconds . fromIntegral . (*) 1000000 +minute = fromMicroseconds . fromIntegral . (*) 60000000 +hour = fromMicroseconds . fromIntegral . (*) 3600000000