silvi 0.0.4 → 0.1.0
raw patch · 10 files changed
+589/−307 lines, 10 filesdep +attoparsecdep +silvidep ~basedep ~chronosdep ~http-types
Dependencies added: attoparsec, silvi
Dependency ranges changed: base, chronos, http-types, ip, quantification, savage
Files
- README.md +1/−3
- silvi.cabal +24/−11
- src/Silvi.hs +7/−5
- src/Silvi/Encode.hs +137/−0
- src/Silvi/Parsers.hs +102/−0
- src/Silvi/Random.hs +69/−53
- src/Silvi/Record.hs +0/−97
- src/Silvi/Tutorial.hs +0/−101
- src/Silvi/Types.hs +159/−37
- tests/TestAll.hs +90/−0
README.md view
@@ -3,9 +3,7 @@ [![Hackage][hackage-badge]][hackage-link] [![License][license-badge]][license-link] -`silvi` is a Haskell library for generating fake logs from user specifications.--See `src/Silvi/Tutorial.hs` for a quick tutorial on getting started.+`silvi` is a Haskell library for generating fake data. [hackage-badge]: https://img.shields.io/hackage/v/silvi.svg?label=Hackage
silvi.cabal view
@@ -1,7 +1,7 @@ --------------------------------------------------------------------- name: silvi-version: 0.0.4+version: 0.1.0 build-type: Simple cabal-version: >= 1.10 category: Development, Testing@@ -15,9 +15,9 @@ tested-with: GHC == 8.0.2 , GHC == 8.2.1 , GHC == 8.2.2-synopsis: A generator for different kinds of logs.-description: A Haskell library for generating logs- from user specifications.+synopsis: A generator for different kinds of data.+description: A Haskell library for generating fake+ data. --------------------------------------------------------------------- @@ -31,19 +31,32 @@ library hs-source-dirs: src build-depends: base >= 4.9 && < 5.0+ , attoparsec , bytestring- , chronos >= 1.0.1 && < 1.0.3- , http-types >= 0.11 && < 0.13- , ip >= 1.0 && < 2.0- , quantification >= 0.3 && < 0.5- , savage >= 1.0.3 && < 2.0+ , chronos >= 1.0.2+ , http-types >= 0.11+ , ip >= 1.1.1+ , quantification+ , savage , text exposed-modules: Silvi+ , Silvi.Encode + , Silvi.Parsers , Silvi.Random- , Silvi.Record , Silvi.Types- , Silvi.Tutorial default-language: Haskell2010 other-extensions: ++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: TestAll.hs+ build-depends:+ base+ , quantification + , savage+ , silvi+ , text+ default-language: Haskell2010 ---------------------------------------------------------------------
src/Silvi.hs view
@@ -1,11 +1,13 @@ {-# OPTIONS_GHC -fno-warn-missing-import-lists #-} module Silvi- ( module Silvi.Random- , module Silvi.Record+ ( module Silvi.Encode + , module Silvi.Parsers + , module Silvi.Random , module Silvi.Types ) where -import Silvi.Random-import Silvi.Record-import Silvi.Types+import Silvi.Encode+import Silvi.Parsers+import Silvi.Random+import Silvi.Types
+ src/Silvi/Encode.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Silvi.Encode+ ( Encode(..)+ ) where++{-# OPTIONS_GHC -Wall #-}++import Chronos.Types+import Data.Int+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Data.Word+import qualified Net.IPv4 as I4+import qualified Net.IPv6 as I6+import Net.Types (IPv4, IPv6)+import qualified Network.HTTP.Types.Method as HttpM+import qualified Network.HTTP.Types.Status as HttpS+import qualified Network.HTTP.Types.Version as HttpV+import Silvi.Types++class Encode a where+ encode :: a -> Text+ print :: a -> IO ()++ default print :: a -> IO ()+ print x = TIO.putStr $ (encode x) `T.append` " "+ default encode :: Show a => a -> Text+ encode = T.pack . show++instance Encode (Value a) where+ encode = \case+ ValueBracketNum x -> encode x+ ValueHttpMethod x -> encode x+ ValueHttpStatus x -> encode x+ ValueHttpVersion x -> encode x + ValueHttpProtocol x -> encode x + ValueUrl x -> encode x+ ValueUserId x -> encode x+ ValueObjSize x -> encode x+ ValueIPv4 x -> encode x+ ValueIPv6 x -> encode x+ ValueTimestamp x -> encode x+ ValueOffset x -> encode x+ ValueDatetime x -> encode x + ValueDate x -> encode x+ ValueYear x -> encode x+ ValueMonth x -> encode x+ ValueDayOfMonth x -> encode x+ ValueTimeOfDay x -> encode x++instance Encode Text where+ encode = id++instance Encode String where+ encode = T.pack++instance Encode Int where++instance Encode Int8 where++instance Encode Int16 where++instance Encode Int32 where++instance Encode Int64 where++instance Encode Word where++instance Encode Word8 where++instance Encode Word16 where++instance Encode Word32 where++instance Encode Word64 where++instance Encode Url where+ encode (Url x) = x++instance Encode UserId where+ encode (UserId x) = x++instance Encode ObjSize where+ encode (ObjSize x) = encode x++instance Encode BracketNum where+ encode (BracketNum x) = "<" `T.append` encode x `T.append` ">"++instance Encode HttpProtocol where++instance Encode IPv4 where+ encode = I4.encode+ print = I4.print++instance Encode IPv6 where+ encode = I6.encode+ print = I6.print++instance Encode HttpM.StdMethod where+ encode = T.pack . show++instance Encode HttpS.Status where+ encode = T.pack . show . HttpS.statusCode++instance Encode HttpV.HttpVersion where+ encode = T.pack . show++instance Encode OffsetDatetime where+ encode x = "[" `T.append` encode (offsetDatetimeDatetime x) `T.append` " -" `T.append` encode (offsetDatetimeOffset x) `T.append` "]"++instance Encode Year where+ encode = encode . getYear++instance Encode Month where+ encode = encode . getMonth++instance Encode DayOfMonth where+ encode = encode . getDayOfMonth++instance Encode Date where+ encode x = encode (dateYear x) `T.append` "/" `T.append` encode (dateMonth x) `T.append` "/" `T.append` encode (dateDay x)++instance Encode TimeOfDay where+ encode x = encode (timeOfDayHour x) `T.append` ":" `T.append` encode (timeOfDayMinute x) `T.append` ":" `T.append` encode (timeOfDayNanoseconds x) ++instance Encode Datetime where+ encode x = encode (datetimeDate x) `T.append` encode (datetimeTime x)++instance Encode Offset where+ encode = encode . getOffset
+ src/Silvi/Parsers.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE OverloadedStrings #-}++module Silvi.Parsers + ( parseIPv4+ , parseIPv6+ , parseHttpMethod+ , parseHttpStatus + , parseHttpVersion + , parseHttpProtocol + , parseUserIdent + , parseUrl + , parseTimestamp + ) where++{-# OPTIONS_GHC -Wall #-}++import Chronos+import Chronos.Types+import Control.Applicative+import Data.Attoparsec.Text (asciiCI, decimal, takeTill, Parser) +import Data.Text (Text)+import Net.Types (IPv4, IPv6)+import Silvi.Types+import qualified Net.IPv4 as I4+import qualified Net.IPv6 as I6+import qualified Network.HTTP.Types.Method as HttpM+import qualified Network.HTTP.Types.Status as HttpS+import qualified Network.HTTP.Types.Version as HttpV+import qualified Data.Attoparsec.Text as Atto+import qualified Data.Text as T++-- | Useful aliases for parsing+colon, dash, dot, fullStop, leftBracket, period, quote, rightBracket, slash, space :: Parser Char+colon = Atto.char ':'+dash = Atto.char '-'+dot = period+fullStop = period+leftBracket = Atto.char '['+period = Atto.char '.'+quote = Atto.char '"'+rightBracket = Atto.char ']'+slash = Atto.char '/'+space = Atto.char ' '++parseIPv4 :: Parser IPv4+parseIPv4 = I4.parser++parseIPv6 :: Parser IPv6+parseIPv6 = I6.parser++parseHttpMethod :: Parser HttpM.Method+parseHttpMethod = do+ (asciiCI "GET" *> pure HttpM.methodGet )+ <|> (asciiCI "POST" *> pure HttpM.methodPost ) + <|> (asciiCI "HEAD" *> pure HttpM.methodHead )+ <|> (asciiCI "PUT" *> pure HttpM.methodPut )+ <|> (asciiCI "DELETE" *> pure HttpM.methodDelete )+ <|> (asciiCI "TRACE" *> pure HttpM.methodTrace )+ <|> (asciiCI "CONNECT" *> pure HttpM.methodConnect)+ <|> (asciiCI "OPTIONS" *> pure HttpM.methodOptions)+ <|> (asciiCI "PATCH" *> pure HttpM.methodPatch )+ <|> fail "Invalid HTTP Method"++parseHttpStatus :: Parser HttpS.Status+parseHttpStatus = toEnum <$> decimal++parseHttpProtocol :: Parser HttpProtocol+parseHttpProtocol = + (asciiCI "HTTPS" *> pure HTTPS)+ <|> (asciiCI "HTTP" *> pure HTTP )+ <|> (asciiCI "FTP" *> pure FTP )+ <|> fail "Invalid HTTP Protocol"++parseHttpVersion :: Parser HttpV.HttpVersion+parseHttpVersion = HttpV.HttpVersion+ <$> decimal + <*> (period *> decimal)++parseUserIdent :: Parser (Maybe Text)+parseUserIdent = do+ ident <- takeTill (== ' ')+ pure $ if ((T.length ident) == 1) && (T.head ident) == '-' then Nothing else Just ident++parseObjSize :: Parser Int+parseObjSize = decimal <* space++--parseQuote :: Parser (Maybe Text)+--parseQuote = fmap refTest (quote *> takeTill (== '"') <* quote)+-- where refTest r = if (T.length r == 0) then Nothing else Just r++parseUrl :: Parser Text+parseUrl = takeTill (== ' ')++--[dd/mm/yyyy:hh:mm:ss -zzzz]+parseTimestamp :: Parser OffsetDatetime+parseTimestamp = do+ leftBracket+ odt <- parser_DmyHMSz (offsetFormat) (datetimeFormat)+ rightBracket+ pure odt+ where offsetFormat = OffsetFormatColonOff+ datetimeFormat = DatetimeFormat (Just '/') (Just ':') (Just ':')
src/Silvi/Random.hs view
@@ -6,61 +6,68 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-}+ module Silvi.Random ( randLogExplicit , randLog- , print - , printMany - , Gen(..) + , printLog + , printLogMany ) where import qualified Chronos import Chronos.Types-import Control.Applicative (liftA2)-import Control.Monad (replicateM, replicateM_)-import Control.Monad.IO.Class (MonadIO(..))-import Data.Exists (Exists (..), Reify (..), SingList (..))-import Data.Text (Text)-import Data.Word (Word8)-import Net.IPv4 (ipv4)-import Net.Types (IPv4 (..))+import Control.Applicative (liftA2)+import Control.Monad (join, replicateM_)+import Data.Exists (Reify (..), SingList (..))+import qualified Data.Text.IO as TIO+import Net.IPv4 (ipv4)+import Net.IPv6 (ipv6)+import Net.Types (IPv4(..),IPv6(..))+import Savage+import Savage.Randy (sample, element, enum, enumBounded, word8, word16)+import Savage.Range (constantBounded)+import qualified Silvi.Encode as E+import Silvi.Types+import Topaz.Rec (Rec (..), fromSingList)+import qualified Topaz.Rec as Topaz import qualified Network.HTTP.Types.Method as HttpM import qualified Network.HTTP.Types.Status as HttpS import Network.HTTP.Types.Version (http09, http10, http11, http20) import qualified Network.HTTP.Types.Version as HttpV-import Savage-import Savage.Internal.Gen (printOnly)-import Savage.Randy (element, enum, enumBounded, int, int8, word16, word8)-import Savage.Range (constantBounded)-import Silvi.Record (Field (..), SingField (..), Value (..))-import Silvi.Types-import Topaz.Rec (Rec (..), fromSingList)-import qualified Topaz.Rec as Topaz-import Prelude hiding (print) rand :: SingField a -> Gen (Value a) rand = \case- SingBracketNum -> ValueBracketNum <$> randomBracketNum- SingHttpMethod -> ValueHttpMethod <$> randomHttpMethod- SingHttpStatus -> ValueHttpStatus <$> randomHttpStatus- SingHttpVersion -> ValueHttpVersion <$> randomHttpVersion- SingUrl -> ValueUrl <$> randomUrl- SingUserId -> ValueUserId <$> randomUserident- SingObjSize -> ValueObjSize <$> randomObjSize- SingIp -> ValueIp <$> randomIPv4- SingTimestamp -> ValueTimestamp <$> randomOffsetDatetime+ SingBracketNum -> ValueBracketNum <$> randomBracketNum+ SingHttpMethod -> ValueHttpMethod <$> randomHttpMethod+ SingHttpStatus -> ValueHttpStatus <$> randomHttpStatus+ SingHttpVersion -> ValueHttpVersion <$> randomHttpVersion+ SingHttpProtocol -> ValueHttpProtocol<$> randomHttpProtocol+ SingUrl -> ValueUrl <$> randomUrl+ SingUserId -> ValueUserId <$> randomUserident+ SingObjSize -> ValueObjSize <$> randomObjSize+ SingIPv4 -> ValueIPv4 <$> randomIPv4+ SingIPv6 -> ValueIPv6 <$> randomIPv6 + SingTimestamp -> ValueTimestamp <$> randomOffsetDatetime+ SingOffset -> ValueOffset <$> randomOffset+ SingDatetime -> ValueDatetime <$> randomDatetime+ SingDate -> ValueDate <$> randomDate+ SingYear -> ValueYear <$> randomYear 1995 2021+ SingMonth -> ValueMonth <$> randomMonth+ SingDayOfMonth -> ValueDayOfMonth <$> (join $ liftA2 randomDayOfMonth (randomYear 1995 2021) (randomMonth))+ SingTimeOfDay -> ValueTimeOfDay <$> randomTimeOfDay -randLog :: forall as. (Reify as) => Gen (Rec Value as)+randLog :: forall as. (Reify as) => Silvi as randLog = randLogExplicit (fromSingList (reify :: SingList as)) -randLogExplicit :: Rec SingField rs -> Gen (Rec Value rs)+randLogExplicit :: Rec SingField rs -> Silvi rs randLogExplicit = Topaz.traverse rand -print :: (MonadIO m, Show a) => Gen a -> m ()-print = printOnly+printLog :: Silvi as -> IO ()+printLog = join . sample . fmap (Topaz.traverse_ E.print) -printMany :: (MonadIO m, Show a) => Int -> Gen a -> m ()-printMany n gen = replicateM_ n (print gen)+printLogMany :: Int -> Silvi as -> IO ()+printLogMany n gen = replicateM_ n (printLog gen >> TIO.putStrLn "") randomIPv4 :: Gen IPv4 randomIPv4 = ipv4@@ -69,6 +76,17 @@ <*> word8 constantBounded <*> word8 constantBounded +randomIPv6 :: Gen IPv6+randomIPv6 = ipv6+ <$> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ <*> word16 constantBounded+ randomBracketNum :: Gen BracketNum randomBracketNum = BracketNum <$> word8 constantBounded @@ -81,6 +99,9 @@ randomHttpVersion :: Gen HttpV.HttpVersion randomHttpVersion = element [http09, http10, http11, http20] +randomHttpProtocol :: Gen HttpProtocol+randomHttpProtocol = element [HTTPS, HTTP, FTP]+ randomUserident :: Gen UserId randomUserident = element userIdents @@ -104,26 +125,23 @@ randomDate :: Gen Date randomDate = do let year = randomYear 1995 2021- month = Month <$> int constantBounded- day = randomDay 1 =<< liftA2 daysUpperBound year month- Date <$> year <*> month <*> day- where daysUpperBound :: Year -> Month -> Int- daysUpperBound y m = Chronos.daysInMonth (Chronos.isLeapYear y) m+ month = enumBounded+ day = liftA2 randomDayOfMonth year month+ Date <$> year <*> month <*> (join day) randomYear :: Int -- ^ Origin year -> Int -- ^ End year -> Gen Year randomYear a b = Year <$> enum (min a b) (max a b) -randomMonth :: Int -- ^ Origin month- -> Int -- ^ End month- -> Gen Month-randomMonth a b = Month <$> enum (min a b) (max a b)+randomMonth :: Gen Month+randomMonth = enumBounded -randomDay :: Int -- ^ Origin Day- -> Int -- ^ End day- -> Gen DayOfMonth-randomDay a b = DayOfMonth <$> enum (min a b) (max a b)+randomDayOfMonth :: Year+ -> Month+ -> Gen DayOfMonth+randomDayOfMonth year month = DayOfMonth <$> enum 1 b+ where b = (\y m -> Chronos.daysInMonth (Chronos.isLeapYear y) m) year month randomOffsetDatetime :: Gen OffsetDatetime randomOffsetDatetime = OffsetDatetime@@ -137,14 +155,12 @@ -- | List of Time Zone Offsets. See: -- https://en.wikipedia.org/wiki/List_of_time_zone_abbreviations offsets :: [Offset]-offsets = map Offset [100,200,300,330,400,430,500,530,545,600,630,700,800,845,900,930,1000,1030,1100,1200,1245,1300,1345,1400,0,-100,-200,-230,-300,-330,-400,-500,-600,-700,-800,-900,-930,-1000,-1100,-1200]+offsets = fmap Offset [100,200,300,330,400,430,500,530,545,600,630,700,800,845,900,930,1000,1030,1100,1200,1245,1300,1345,1400,0,-100,-200,-230,-300,-330,-400,-500,-600,-700,-800,-900,-930,-1000,-1100,-1200] -- | List of sample Useridents. userIdents :: [UserId]-userIdents = map UserId ["-","andrewthad","cement","chessai"]+userIdents = fmap UserId ["-","andrewthad","cement","chessai"] -- | List of sample URLs. urls :: [Url]-urls = map Url ["https://github.com","https://youtube.com","layer3com.com"]--+urls = fmap Url ["https://github.com","https://youtube.com","layer3com.com"]
− src/Silvi/Record.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeInType #-}-{-# LANGUAGE TypeOperators #-}--module Silvi.Record- ( Field(..)- , Value(..)- , SingField(..)- , Rec(..) - ) where--import Chronos.Types (OffsetDatetime (..))-import Data.Exists (Exists (..), Reify (..),- ShowForall (..), Sing)-import Data.Kind (Type)-import Data.Text (Text)-import GHC.Generics (Generic)-import Net.Types (IPv4)-import qualified Network.HTTP.Types.Method as HttpM-import qualified Network.HTTP.Types.Status as HttpS-import qualified Network.HTTP.Types.Version as HttpV-import Silvi.Types-import Topaz.Rec (Rec(..), traverse)-import qualified Topaz.Rec as Topaz---- | Different types present in logs.-data Field- = FieldBracketNum -- ^ Number that appears before many logs, in the form of "<X>"- | FieldHttpMethod -- ^ More explicit name for Network.HTTP.Types.Method- | FieldHttpStatus -- ^ More explicit name for Network.HTTP.Types.Status- | FieldHttpVersion -- ^ More explicit name for Network.HTTP.Types.Version- | FieldUrl -- ^ a url, e.g. "https://hackage.haskell.org"- | FieldUserId -- ^ userId as Text- | FieldObjSize -- ^ usually requested resource size- | FieldIp -- ^ FieldIp present in log- | FieldTimestamp -- ^ Timestamp- deriving (Bounded,Enum,Eq,Generic,Ord,Read,Show)--data Value :: Field -> Type where- ValueBracketNum :: BracketNum -> Value 'FieldBracketNum- ValueHttpMethod :: HttpM.StdMethod -> Value 'FieldHttpMethod- ValueHttpStatus :: HttpS.Status -> Value 'FieldHttpStatus- ValueHttpVersion :: HttpV.HttpVersion -> Value 'FieldHttpVersion- ValueUrl :: Url -> Value 'FieldUrl- ValueUserId :: UserId -> Value 'FieldUserId- ValueObjSize :: ObjSize -> Value 'FieldObjSize- ValueIp :: IPv4 -> Value 'FieldIp- ValueTimestamp :: OffsetDatetime -> Value 'FieldTimestamp--instance ShowForall Value where- showsPrecForall p (ValueBracketNum x) = showParen (p > 10) $ showString "ValueBracketNum" . showsPrec 11 x- showsPrecForall p (ValueHttpMethod x) = showParen (p > 10) $ showString "ValueHttpMethod" . showsPrec 11 x- showsPrecForall p (ValueHttpStatus x) = showParen (p > 10) $ showString "ValueHttpStatus" . showsPrec 11 x- showsPrecForall p (ValueHttpVersion x) = showParen (p > 10) $ showString "ValueHttpVersion" . showsPrec 11 x- showsPrecForall p (ValueUrl x) = showParen (p > 10) $ showString "ValueUrl" . showsPrec 11 x- showsPrecForall p (ValueUserId x) = showParen (p > 10) $ showString "ValueUserId" . showsPrec 11 x- showsPrecForall p (ValueObjSize x) = showParen (p > 10) $ showString "ValueObjSize" . showsPrec 11 x- showsPrecForall p (ValueIp x) = showParen (p > 10) $ showString "ValueIp" . showsPrec 11 x- showsPrecForall p (ValueTimestamp x) = showParen (p > 10) $ showString "ValueTimestamp" . showsPrec 11 x--data SingField :: Field -> Type where- SingBracketNum :: SingField 'FieldBracketNum- SingHttpMethod :: SingField 'FieldHttpMethod- SingHttpStatus :: SingField 'FieldHttpStatus- SingHttpVersion :: SingField 'FieldHttpVersion- SingUrl :: SingField 'FieldUrl- SingUserId :: SingField 'FieldUserId- SingObjSize :: SingField 'FieldObjSize- SingIp :: SingField 'FieldIp- SingTimestamp :: SingField 'FieldTimestamp--type instance Sing = SingField--instance Reify 'FieldBracketNum where- reify = SingBracketNum-instance Reify 'FieldHttpMethod where- reify = SingHttpMethod-instance Reify 'FieldHttpStatus where- reify = SingHttpStatus-instance Reify 'FieldHttpVersion where- reify = SingHttpVersion-instance Reify 'FieldUrl where- reify = SingUrl-instance Reify 'FieldUserId where- reify = SingUserId-instance Reify 'FieldObjSize where- reify = SingObjSize-instance Reify 'FieldIp where- reify = SingIp-instance Reify 'FieldTimestamp where- reify = SingTimestamp
− src/Silvi/Tutorial.hs
@@ -1,101 +0,0 @@--- -*- coding: utf-8; mode: haskell; -*----- File: src/Silvi/Tutorial.hs------ License:--- Copyright 2017 Daniel Cartwright------ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:------ 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.------ 2. 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.------ 3. Neither the name of the copyright holder nor the names of its 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 HOLDER 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.--{-# OPTIONS_GHC -fno-warn-unused-imports #-}--{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}---- |--- Module : Silvi.Tutorial--- Copyright : Copyright 2017 Daniel Cartwright--- License : BSD3--- Maintainer : dcartwright@layer3com.com--- Stability : stable-module Silvi.Tutorial- ( -- * Introduction- -- $introduction-- -- * Defining Log Formats- -- $def_logs- - -- * Generating Random Logs- -- $rand_logs- --- --- ) where--import Silvi.Random (randLog, printMany, Gen(..))-import Silvi.Record (Field (..), SingField (..), Value (..), Rec(..))-------------------------------------------------------------------------------------- $introduction------ This library allows you to generate random logs, as well as easily construct--- any sort of log you might yourself want.------ In general, when using @silvi@, you'll want the following language extensions:------ @--- {-# LANGUAGE DataKinds #-}--- {-# LANGUAGE OverloadedStrings #-}--- {-# LANGUAGE TypeApplications #-}--- @------ And the following imports:------ @--- import Silvi.Random--- import Silvi.Record--- @--- --------------------------------------------------------------------------------------- $def_logs------ > -- It is easy to define a log. --- > -- A log is represented as a type-level list consisting of different fields.--- >--- > -- 'SimpleLog' represents a Log consisting of just an IPv4 address and a URL.--- > type SimpleLog = '[ FieldIp--- > , FieldUrl--- > ]--type SimpleLog = '[ FieldIp- , FieldUrl- ]--------------------------------------------------------------------------------------- $rand_logs--- >--- > -- 'randSimpleLog' now contains a SimpleLog with randomised inhabitants of the IPv4 and URL types.--- > randSimpleLog :: Gen (Rec Value as)--- > randSimpleLog = randLog @SimpleLog--- > --- > -- 'main' will print out 1000 'SimpleLog's.--- > main :: IO ()--- > main = printMany 1000 randSimpleLog--randSimpleLog :: Gen (Rec Value SimpleLog)-randSimpleLog = randLog @SimpleLog--main :: IO ()-main = printMany 1000 randSimpleLog
src/Silvi/Types.hs view
@@ -1,58 +1,180 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -Wall #-}+ module Silvi.Types ( Url(..) , UserId(..) , ObjSize(..) , BracketNum(..)- , Log(..) + , HttpProtocol(..) + , Field(..)+ , Value(..)+ , SingField(..) + , Silvi ) where -import Data.Exists-import Data.Text (Text)-import Data.Word (Word16, Word8)-import Topaz.Rec (Rec(..))+import Chronos.Types+import Data.Exists (Reify (..), ShowForall (..), Sing)+import Data.Kind (Type)+import Data.Text (Text)+import Data.Word+import GHC.Generics (Generic)+import Net.Types (IPv4,IPv6)+import qualified Network.HTTP.Types.Method as HttpM+import qualified Network.HTTP.Types.Status as HttpS+import qualified Network.HTTP.Types.Version as HttpV+import Savage (Gen)+import Topaz.Rec (Rec(..)) -newtype Log v a = Log { getLog :: Rec v a }- deriving (Eq)+type Silvi a = Gen (Rec Value a) -instance ShowForall f => ShowForall (Log f) where- showsPrecForall p x = case getLog x of- RecCons v vs -> showParen (p > 10)- $ showsPrecForall 11 v- . showString " "- . showsPrecForall 11 vs- RecNil -> showString ""+-- | Different types present in logs.+data Field+ = FieldBracketNum -- ^ Number that appears before many logs, in the form of "<X>"+ | FieldHttpMethod -- ^ More explicit name for Network.HTTP.Types.Method+ | FieldHttpStatus -- ^ More explicit name for Network.HTTP.Types.Status+ | FieldHttpVersion -- ^ More explicit name for Network.HTTP.Types.Version+ | FieldHttpProtocol -- ^ HTTP/2, HTTP, FTP + | FieldUrl -- ^ a url, e.g. "https://hackage.haskell.org"+ | FieldUserId -- ^ userId as Text+ | FieldObjSize -- ^ usually requested resource size+ | FieldIPv4 -- ^ IPv4 present in log+ | FieldIPv6 -- ^ IPv6 address+ | FieldTimestamp -- ^ Timestamp+ | FieldOffset -- ^ Time offset (from UTC)+ | FieldDatetime -- ^ Date (YYyy/Mm/Dd) ++ TimeOfDay (Hh:Mm:Ss)+ | FieldDate -- ^ Date (YYyy/Mm/Dd)+ | FieldYear -- ^ Year (YYyy/_/_)+ | FieldMonth -- ^ Month (_/Mm/_) + | FieldDayOfMonth -- ^ DayOfMonth (_/_/Dd)+ | FieldTimeOfDay -- ^ (Hh:Mm:Ss) + deriving (Bounded,Enum,Eq,Generic,Ord,Read,Show) +data Value :: Field -> Type where+ ValueBracketNum :: BracketNum -> Value 'FieldBracketNum+ ValueHttpMethod :: HttpM.StdMethod -> Value 'FieldHttpMethod+ ValueHttpStatus :: HttpS.Status -> Value 'FieldHttpStatus+ ValueHttpVersion :: HttpV.HttpVersion -> Value 'FieldHttpVersion+ ValueHttpProtocol :: HttpProtocol -> Value 'FieldHttpProtocol + ValueUrl :: Url -> Value 'FieldUrl+ ValueUserId :: UserId -> Value 'FieldUserId+ ValueObjSize :: ObjSize -> Value 'FieldObjSize+ ValueIPv4 :: IPv4 -> Value 'FieldIPv4+ ValueIPv6 :: IPv6 -> Value 'FieldIPv6+ ValueTimestamp :: OffsetDatetime -> Value 'FieldTimestamp+ ValueOffset :: Offset -> Value 'FieldOffset+ ValueDatetime :: Datetime -> Value 'FieldDatetime+ ValueDate :: Date -> Value 'FieldDate+ ValueYear :: Year -> Value 'FieldYear+ ValueMonth :: Month -> Value 'FieldMonth+ ValueDayOfMonth :: DayOfMonth -> Value 'FieldDayOfMonth+ ValueTimeOfDay :: TimeOfDay -> Value 'FieldTimeOfDay++instance ShowForall Value where+ showsPrecForall p (ValueBracketNum x) = showParen (p > 10) $ showString "ValueBracketNum" . showsPrec 11 x+ showsPrecForall p (ValueHttpMethod x) = showParen (p > 10) $ showString "ValueHttpMethod" . showsPrec 11 x+ showsPrecForall p (ValueHttpStatus x) = showParen (p > 10) $ showString "ValueHttpStatus" . showsPrec 11 x+ showsPrecForall p (ValueHttpVersion x) = showParen (p > 10) $ showString "ValueHttpVersion" . showsPrec 11 x+ showsPrecForall p (ValueHttpProtocol x)= showParen (p > 10) $ showString "ValueHttpProtocol". showsPrec 11 x + showsPrecForall p (ValueUrl x) = showParen (p > 10) $ showString "ValueUrl" . showsPrec 11 x+ showsPrecForall p (ValueUserId x) = showParen (p > 10) $ showString "ValueUserId" . showsPrec 11 x+ showsPrecForall p (ValueObjSize x) = showParen (p > 10) $ showString "ValueObjSize" . showsPrec 11 x+ showsPrecForall p (ValueIPv4 x) = showParen (p > 10) $ showString "ValueIPv4" . showsPrec 11 x+ showsPrecForall p (ValueIPv6 x) = showParen (p > 10) $ showString "ValueIPv6" . showsPrec 11 x+ showsPrecForall p (ValueTimestamp x) = showParen (p > 10) $ showString "ValueTimestamp" . showsPrec 11 x+ showsPrecForall p (ValueOffset x) = showParen (p > 10) $ showString "ValueOffset" . showsPrec 11 x+ showsPrecForall p (ValueDatetime x) = showParen (p > 10) $ showString "ValueDatetime" . showsPrec 11 x+ showsPrecForall p (ValueDate x) = showParen (p > 10) $ showString "ValueDate" . showsPrec 11 x+ showsPrecForall p (ValueYear x) = showParen (p > 10) $ showString "ValueYear" . showsPrec 11 x+ showsPrecForall p (ValueMonth x) = showParen (p > 10) $ showString "ValueMonth" . showsPrec 11 x+ showsPrecForall p (ValueDayOfMonth x) = showParen (p > 10) $ showString "ValueDayOfMonth" . showsPrec 11 x+ showsPrecForall p (ValueTimeOfDay x) = showParen (p > 10) $ showString "ValueTimeOfDay" . showsPrec 11 x++data SingField :: Field -> Type where+ SingBracketNum :: SingField 'FieldBracketNum+ SingHttpMethod :: SingField 'FieldHttpMethod+ SingHttpStatus :: SingField 'FieldHttpStatus+ SingHttpVersion :: SingField 'FieldHttpVersion+ SingHttpProtocol :: SingField 'FieldHttpProtocol + SingUrl :: SingField 'FieldUrl+ SingUserId :: SingField 'FieldUserId+ SingObjSize :: SingField 'FieldObjSize+ SingIPv4 :: SingField 'FieldIPv4+ SingIPv6 :: SingField 'FieldIPv6+ SingTimestamp :: SingField 'FieldTimestamp+ SingOffset :: SingField 'FieldOffset+ SingDatetime :: SingField 'FieldDatetime+ SingDate :: SingField 'FieldDate+ SingYear :: SingField 'FieldYear+ SingMonth :: SingField 'FieldMonth+ SingDayOfMonth :: SingField 'FieldDayOfMonth+ SingTimeOfDay :: SingField 'FieldTimeOfDay++type instance Sing = SingField++instance Reify 'FieldBracketNum where+ reify = SingBracketNum+instance Reify 'FieldHttpMethod where+ reify = SingHttpMethod+instance Reify 'FieldHttpStatus where+ reify = SingHttpStatus+instance Reify 'FieldHttpVersion where+ reify = SingHttpVersion+instance Reify 'FieldHttpProtocol where+ reify = SingHttpProtocol+instance Reify 'FieldUrl where+ reify = SingUrl+instance Reify 'FieldUserId where+ reify = SingUserId+instance Reify 'FieldObjSize where+ reify = SingObjSize+instance Reify 'FieldIPv4 where+ reify = SingIPv4+instance Reify 'FieldIPv6 where+ reify = SingIPv6+instance Reify 'FieldTimestamp where+ reify = SingTimestamp+instance Reify 'FieldOffset where+ reify = SingOffset+instance Reify 'FieldDatetime where+ reify = SingDatetime+instance Reify 'FieldDate where+ reify = SingDate+instance Reify 'FieldYear where+ reify = SingYear+instance Reify 'FieldMonth where+ reify = SingMonth+instance Reify 'FieldDayOfMonth where+ reify = SingDayOfMonth+instance Reify 'FieldTimeOfDay where+ reify = SingTimeOfDay++-- | HTTP Protocol used.+data HttpProtocol = HTTPS | HTTP | FTP+ deriving (Eq, Show)+ -- | Url type.--- TODO: Expand on this for better randomisation.--- newtype Url = Url { getUrl :: Text }- deriving (Eq)--instance Show Url where- show (Url x) = show x+ deriving (Eq, Show) -- | UserId type.--- newtype UserId = UserId { getUserId :: Text }- deriving (Eq)--instance Show UserId where- show (UserId x) = show x+ deriving (Eq, Show) -- | Requested resource size.--- newtype ObjSize = ObjSize { getObjSize :: Word16 }- deriving (Eq)--instance Show ObjSize where- show (ObjSize x) = show x ++ "B"+ deriving (Eq, Show) --- | Angle-bracketed number that appears before many logs.---+-- | Angle-bracketed number that appears before some logs. newtype BracketNum = BracketNum { getBracketNum :: Word8 }- deriving (Eq)--instance Show BracketNum where- show (BracketNum x) = "<" ++ show x ++ ">"+ deriving (Eq, Show)
+ tests/TestAll.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++import Control.Monad+import Data.Text (Text)+import Silvi.Random+import Silvi.Types+import Savage+import Savage.Randy (sample)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import qualified Silvi.Encode as E+import qualified Topaz.Rec as Topaz++-- /begin Fallback section+-- These functions are provided in the event of failure;+-- they expose more details to the tester.+testAnnounce :: Text -> IO ()+testAnnounce x = do+ TIO.putStrLn "================================"+ replicateM_ ((32 - T.length x) `div` 2) (TIO.putStr "=") + TIO.putStr x+ replicateM_ ((32 - T.length x) `div` 2) (TIO.putStr "=") + TIO.putStrLn "" + TIO.putStrLn "================================"++success :: Text -> IO ()+success x = do+ TIO.putStrLn ""+ TIO.putStrLn $ "Succeeded: " `T.append` x++ms :: Silvi a -> Text -> IO ()+ms s name = do+ testAnnounce name+ let ot :: Gen (IO ())+ ot = fmap (Topaz.traverse_ E.print) s+ ok :: IO (IO ())+ ok = sample ot+ join ok+ success name++fallback :: IO ()+fallback = do+ ms (randLog @('[ 'FieldBracketNum ])) "BracketNum"+ ms (randLog @('[ 'FieldHttpMethod ])) "HttpMethod"+ ms (randLog @('[ 'FieldHttpStatus ])) "HttpStatus"+ ms (randLog @('[ 'FieldHttpVersion ])) "HttpVersion"+ ms (randLog @('[ 'FieldHttpProtocol ])) "HttpProtocol"+ ms (randLog @('[ 'FieldUrl ])) "Url"+ ms (randLog @('[ 'FieldUserId ])) "UserId"+ ms (randLog @('[ 'FieldObjSize ])) "ObjSize"+ ms (randLog @('[ 'FieldIPv4 ])) "IPv4"+ ms (randLog @('[ 'FieldIPv6 ])) "IPv6"+ ms (randLog @('[ 'FieldTimestamp ])) "OffsetDatetime"+ ms (randLog @('[ 'FieldOffset ])) "Offset"+ ms (randLog @('[ 'FieldDatetime ])) "Datetime"+ ms (randLog @('[ 'FieldDate ])) "Date"+ ms (randLog @('[ 'FieldYear ])) "Year"+ ms (randLog @('[ 'FieldMonth ])) "Month"+ ms (randLog @('[ 'FieldDayOfMonth ])) "DayOfMonth"+ ms (randLog @('[ 'FieldTimeOfDay ])) "TimeOfDay"+--+-- /end Fallback section++main :: IO ()+main = printMany 100 randAllTypesLog++type AllTypesLog = '[ 'FieldBracketNum+ , 'FieldHttpMethod+ , 'FieldHttpStatus+ , 'FieldHttpVersion+ , 'FieldHttpProtocol + , 'FieldUrl+ , 'FieldUserId+ , 'FieldObjSize+ , 'FieldIPv4+ , 'FieldIPv6+ , 'FieldTimestamp+ , 'FieldOffset+ , 'FieldDatetime+ , 'FieldDate+ , 'FieldYear+ , 'FieldMonth+ , 'FieldDayOfMonth+ , 'FieldTimeOfDay+ ]++randAllTypesLog :: Silvi AllTypesLog+randAllTypesLog = randLog @AllTypesLog