api-tools 0.8.0.2 → 0.9.0.0
raw patch · 27 files changed
+591/−392 lines, 27 filesdep +criteriondep −Cabaldep −old-localedep −semigroupsdep ~QuickCheckdep ~aesondep ~base
Dependencies added: criterion
Dependencies removed: Cabal, old-locale, semigroups
Dependency ranges changed: QuickCheck, aeson, base, base16-bytestring, base64-bytestring, bytestring, lens, safecopy, tasty, template-haskell, text, time
Files
- api-tools.cabal +38/−37
- bench/Main.hs +28/−0
- changelog +5/−0
- main/Data/API/MigrationTool.hs +0/−98
- main/Data/API/PerfTest.hs +0/−55
- main/MigrationTool.hs +95/−0
- main/PerfTest.hs +51/−0
- src/Data/API/JSON.hs +10/−3
- src/Data/API/JSONToCBOR.hs +5/−6
- src/Data/API/Markdown.hs +3/−3
- src/Data/API/Parse.y +4/−4
- src/Data/API/Scan.x +3/−1
- src/Data/API/Time.hs +154/−0
- src/Data/API/Tools/CBOR.hs +2/−1
- src/Data/API/Tools/Enum.hs +0/−1
- src/Data/API/Tools/Example.hs +2/−5
- src/Data/API/Tools/JSON.hs +1/−2
- src/Data/API/Tools/QuickCheck.hs +1/−22
- src/Data/API/Types.hs +87/−91
- src/Data/API/Utils.hs +7/−43
- src/Data/API/Value.hs +2/−1
- src/Data/Binary/Serialise/CBOR/Extra.hs +0/−1
- tests/Data/API/Test/Gen.hs +3/−1
- tests/Data/API/Test/JSON.hs +5/−9
- tests/Data/API/Test/Main.hs +2/−4
- tests/Data/API/Test/MigrationData.hs +4/−4
- tests/Data/API/Test/Time.hs +79/−0
api-tools.cabal view
@@ -1,5 +1,5 @@ Name: api-tools-Version: 0.8.0.2+Version: 0.9.0.0 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the@@ -12,12 +12,12 @@ License-file: LICENSE Author: Chris Dornan <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com> Maintainer: Chris Dornan <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com>-Copyright: (c) Iris Connect 2013-2018+Copyright: (c) Iris Connect 2013-2021 Category: Network, Web, Cloud, Distributed Computing Build-type: Simple Extra-source-files: changelog Cabal-version: >=1.10-Tested-with: GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.2+Tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4 Source-Repository head Type: git@@ -26,10 +26,7 @@ Source-Repository this Type: git Location: git://github.com/iconnect/api-tools.git- Tag: 0.8.0.2--flag time15- default: True+ Tag: 0.9.0.0 Library Hs-Source-Dirs: src@@ -50,6 +47,7 @@ Data.API.Parse Data.API.PP Data.API.TH+ Data.API.Time Data.API.Tools Data.API.Tools.CBOR Data.API.Tools.Combinators@@ -78,43 +76,31 @@ Data.API.TH.Compat Build-depends:- Cabal >= 1.4 && < 2.5 ,- QuickCheck >= 2.5.1 && < 2.13 ,- aeson >= 0.10 && < 1.5 ,+ QuickCheck >= 2.5.1 && < 2.15 ,+ aeson >= 0.10 && < 1.6 , aeson-pretty >= 0.1 && < 0.9 , array >= 0.4 && < 0.6 , attoparsec >= 0.10.4 && < 0.14 ,- base >= 4 && < 5 ,- base16-bytestring >= 0.1 && < 0.2 ,- base64-bytestring >= 1.0 && < 1.1 ,- bytestring >= 0.9 && < 0.11 ,+ base >= 4.9 && < 5 ,+ base16-bytestring >= 0.1 && < 1.1 ,+ base64-bytestring >= 1.0 && < 1.3 ,+ bytestring >= 0.9 && < 0.12 , case-insensitive >= 1.0 && < 1.3 , cborg >= 0.1.1.0 && < 0.3 , containers >= 0.5 && < 0.7 , deepseq >= 1.1 && < 1.5 ,- lens >= 3.8.7 && < 4.18 ,+ lens >= 3.8.7 && < 4.20 , regex-compat-tdfa >= 0.95.1 && < 0.96 , safe >= 0.3.3 && < 0.4 ,- safecopy >= 0.8.1 && < 0.10 ,+ safecopy >= 0.8.1 && < 0.11 , scientific >= 0.3 && < 0.4 , serialise >= 0.1.0.0 && < 0.3 ,- template-haskell >= 2.7 && < 2.15 ,+ template-haskell >= 2.7 && < 2.17 , text >= 0.11.3 && < 1.3 ,+ time >= 1.5.0 && < 1.10, unordered-containers >= 0.2.3.0 && < 0.3 , vector >= 0.10.0.1 && < 0.13 - if flag(time15)- Build-depends:- time >= 1.5.0 && < 1.10- else- Build-depends:- old-locale >= 1 && < 1.1,- time >= 1.1.4 && < 1.5-- if !impl(ghc >= 8.0)- -- Needed for Data.Semigroup before it was in base- build-depends: semigroups == 0.18.*- Build-tools: alex, happy@@ -129,7 +115,7 @@ Executable migration-tool Hs-Source-Dirs: main - Main-is: Data/API/MigrationTool.hs+ Main-is: MigrationTool.hs Build-depends: api-tools,@@ -139,7 +125,6 @@ bytestring GHC-Options:- -main-is Data.API.MigrationTool -Wall -fwarn-tabs @@ -149,7 +134,7 @@ Executable perf-test Hs-Source-Dirs: main - Main-is: Data/API/PerfTest.hs+ Main-is: PerfTest.hs Build-depends: api-tools,@@ -160,7 +145,6 @@ serialise GHC-Options:- -main-is Data.API.PerfTest -Wall -fwarn-tabs -rtsopts@@ -181,10 +165,10 @@ Data.API.Test.JSON Data.API.Test.Migration Data.API.Test.MigrationData+ Data.API.Test.Time Build-depends: api-tools,- Cabal, QuickCheck, aeson, aeson-pretty,@@ -195,7 +179,7 @@ containers, safecopy, serialise,- tasty >= 0.10.1 && < 1.2 ,+ tasty >= 0.10.1 && < 1.5 , tasty-hunit >= 0.2 && < 10.0, tasty-quickcheck >= 0.3 && < 0.11, time,@@ -204,8 +188,25 @@ unordered-containers GHC-Options:- -main-is Data.API.Test.Main -Wall- -fwarn-tabs++ Default-Language: Haskell2010++Benchmark bench-time+ Hs-Source-Dirs: bench++ Type: exitcode-stdio-1.0++ Main-is: Main.hs++ Build-depends:+ api-tools,+ base,+ criterion,+ text,+ time++ GHC-Options:+ -Wall Default-Language: Haskell2010
+ bench/Main.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}++import Criterion.Main+import Data.API.Time+import qualified Data.Text as T+import Data.Time++main :: IO ()+main =+ defaultMain+ [ bgroup "parseUTC_old" [ bench (T.unpack x) $ nf parseUTC_old x+ | x <- time_inputs ]+ , bgroup "parseUTC" [ bench (T.unpack x) $ nf parseUTC x+ | x <- time_inputs ]+ , bgroup "parseDay" [ bench (T.unpack x) $ nf parseUTC x+ | x <- day_inputs ]+ , bgroup "read Day" [ bench (T.unpack x) $ nf (reads . T.unpack :: T.Text -> [(UTCTime,String)]) x+ | x <- day_inputs ]+ ]+ where+ time_inputs = [ "nonsense"+ , "2013-05-27T19:13:50Z"+ , "1965-03-10T09:23:01.000001Z"+ , "2999-03-10T09:23"+ , "2021-03-16T12:24:32+0100"+ ]++ day_inputs = ["nonsense", "2020-11-11" ]
changelog view
@@ -1,5 +1,10 @@ -*-change-log-*- +0.9.0.0 Adam Gundry <adam@well-typed.com> March 2021+ * Adjust dependency bounds and support building on GHC 8.10.x+ * Drop support for GHC verisons older than 8.4.x+ * Expose time parsing API in new module Data.API.Time+ 0.8.0.2 Adam Gundry <adam@well-typed.com> November 2018 * Relax dependency bounds and support building on GHC 8.4.x and 8.6.x
− main/Data/API/MigrationTool.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Data.API.MigrationTool- ( main- ) where--import Data.API.Changes-import Data.API.JSON-import Data.API.Parse-import Data.API.Types--import qualified Data.Aeson as JS-import qualified Data.Aeson.Encode.Pretty as JS-import qualified Data.ByteString.Lazy as BS-import System.Environment-import System.Exit-import System.IO---------------------------------- Main, prototype testing--main :: IO ()-main = do- args <- getArgs- case args of- ["migrate", startApiFile, endApiFile, inDataFile, outDataFile] ->- migrate startApiFile endApiFile inDataFile outDataFile-- ["compare", file1, file2] ->- compareJSON file1 file2-- ["reformat", file1, file2] ->- reformatJSON file1 file2-- ["parse", file] ->- parse file-- _ -> do putStrLn "Usage: migration-tool migrate start.api end.api start.json end.json"- putStrLn " migration-tool compare file1.json file2.json"- putStrLn " migration-tool reformat input.json output.json"- putStrLn " migration-tool parse schema.api"- return ()--migrate :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()-migrate startApiFile endApiFile- inDataFile outDataFile = do-- (startApi, startChangelog) <- readApiFile startApiFile- (endApi, endChangelog) <- readApiFile endApiFile- inData <- readJsonFile inDataFile- let Release startApiVer = changelogVersion startChangelog- case migrateDataDump (startApi, startApiVer) (endApi, DevVersion)- endChangelog customMigrations root CheckAll inData of- Left err -> do- hPutStrLn stderr (prettyMigrateFailure err)- exitFailure- Right (outData, warnings) -> do- putStrLn . unlines . map show $ warnings- writeJsonFile outDataFile outData--root :: TypeName-root = TypeName "DatabaseSnapshot"--readJsonFile :: FromJSONWithErrs b => FilePath -> IO b-readJsonFile file = either (fail . prettyJSONErrorPositions) return- . decodeWithErrs =<< BS.readFile file--writeJsonFile :: JS.ToJSON a => FilePath -> a -> IO ()-writeJsonFile file = BS.writeFile file . JS.encodePretty--readApiFile :: FilePath -> IO APIWithChangelog-readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file)--data ChangeTag = None- deriving (Read, Show)--customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag-customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)- (nope id) (const noSchemaChanges)- (nope id)- where- nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))--compareJSON :: FilePath -> FilePath -> IO ()-compareJSON file1 file2 = do- js1 <- readJsonFile file1- js2 <- readJsonFile file2- print (js1 == (js2 :: JS.Value))--reformatJSON :: FilePath -> FilePath -> IO ()-reformatJSON file1 file2 = do- js <- readJsonFile file1- writeJsonFile file2 (js :: JS.Value)--parse :: FilePath -> IO ()-parse file = do- s <- readFile file- print (parseAPIWithChangelog file (0,0) s)
− main/Data/API/PerfTest.hs
@@ -1,55 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.API.PerfTest- ( main- ) where--import Data.API.API.DSL-import qualified Data.API.API.Gen as Gen-import Data.API.NormalForm-import Data.API.Types-import qualified Data.API.Value as Value--import Control.DeepSeq-import Control.Exception-import qualified Data.Aeson as JS-import qualified Codec.Serialise as CBOR-import Data.Binary.Serialise.CBOR.Extra-import System.Environment-import Test.QuickCheck--tyDesc :: APIType--{--type T = [UTCTime]-tyDesc = TyList (TyBasic BTutc)--}--type T = Gen.APISpec-tyDesc = TyName "APISpec"--newtype V = V { _V :: Value.Value }--instance CBOR.Serialise V where- encode (V v) = Value.encode v- decode = V <$!> Value.decode (apiNormalForm apiAPI) tyDesc--main :: IO ()-main = do- args <- getArgs- case args of- ["read" , fp] -> do x <- CBOR.readFileDeserialise fp- _ <- evaluate (force (x :: T))- return ()- ["read-aeson" , fp] -> do x <- CBOR.readFileDeserialise fp- _ <- evaluate (force (x :: JS.Value))- return ()- ["read-generic", fp] -> do x <- CBOR.readFileDeserialise fp- _ <- evaluate (force (_V x))- return ()- ["write" ,fp] -> do x <- generate (resize 500 arbitrary)- CBOR.writeFileSerialise fp (x :: T)- ["write" ,fp,i] -> do x <- generate (resize (read i) arbitrary)- CBOR.writeFileSerialise fp (x :: T)- _ -> error "perf-test (read|read-generic|write) <file>"
+ main/MigrationTool.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++import Data.API.Changes+import Data.API.JSON+import Data.API.Parse+import Data.API.Types++import qualified Data.Aeson as JS+import qualified Data.Aeson.Encode.Pretty as JS+import qualified Data.ByteString.Lazy as BS+import System.Environment+import System.Exit+import System.IO+++----------------------------+-- Main, prototype testing++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["migrate", startApiFile, endApiFile, inDataFile, outDataFile] ->+ migrate startApiFile endApiFile inDataFile outDataFile++ ["compare", file1, file2] ->+ compareJSON file1 file2++ ["reformat", file1, file2] ->+ reformatJSON file1 file2++ ["parse", file] ->+ parse file++ _ -> do putStrLn "Usage: migration-tool migrate start.api end.api start.json end.json"+ putStrLn " migration-tool compare file1.json file2.json"+ putStrLn " migration-tool reformat input.json output.json"+ putStrLn " migration-tool parse schema.api"+ return ()++migrate :: FilePath -> FilePath -> FilePath -> FilePath -> IO ()+migrate startApiFile endApiFile+ inDataFile outDataFile = do++ (startApi, startChangelog) <- readApiFile startApiFile+ (endApi, endChangelog) <- readApiFile endApiFile+ inData <- readJsonFile inDataFile+ let Release startApiVer = changelogVersion startChangelog+ case migrateDataDump (startApi, startApiVer) (endApi, DevVersion)+ endChangelog customMigrations root CheckAll inData of+ Left err -> do+ hPutStrLn stderr (prettyMigrateFailure err)+ exitFailure+ Right (outData, warnings) -> do+ putStrLn . unlines . map show $ warnings+ writeJsonFile outDataFile outData++root :: TypeName+root = TypeName "DatabaseSnapshot"++readJsonFile :: FromJSONWithErrs b => FilePath -> IO b+readJsonFile file = either (fail . prettyJSONErrorPositions) return+ . decodeWithErrs =<< BS.readFile file++writeJsonFile :: JS.ToJSON a => FilePath -> a -> IO ()+writeJsonFile file = BS.writeFile file . JS.encodePretty++readApiFile :: FilePath -> IO APIWithChangelog+readApiFile file = fmap (parseAPIWithChangelog file (0,0)) (readFile file)++data ChangeTag = None+ deriving (Read, Show)++customMigrations :: CustomMigrations JS.Object JS.Value ChangeTag ChangeTag ChangeTag+customMigrations = CustomMigrations (nope JS.Object) (const noSchemaChanges)+ (nope id) (const noSchemaChanges)+ (nope id)+ where+ nope toVal _ v = Left (CustomMigrationError "No custom migrations defined" (toVal v))++compareJSON :: FilePath -> FilePath -> IO ()+compareJSON file1 file2 = do+ js1 <- readJsonFile file1+ js2 <- readJsonFile file2+ print (js1 == (js2 :: JS.Value))++reformatJSON :: FilePath -> FilePath -> IO ()+reformatJSON file1 file2 = do+ js <- readJsonFile file1+ writeJsonFile file2 (js :: JS.Value)++parse :: FilePath -> IO ()+parse file = do+ s <- readFile file+ print (parseAPIWithChangelog file (0,0) s)
+ main/PerfTest.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++import Data.API.API.DSL+import qualified Data.API.API.Gen as Gen+import Data.API.NormalForm+import Data.API.Types+import qualified Data.API.Value as Value++import Control.DeepSeq+import Control.Exception+import qualified Data.Aeson as JS+import qualified Codec.Serialise as CBOR+import Data.Binary.Serialise.CBOR.Extra+import System.Environment+import Test.QuickCheck++tyDesc :: APIType++{-+type T = [UTCTime]+tyDesc = TyList (TyBasic BTutc)+-}++type T = Gen.APISpec+tyDesc = TyName "APISpec"++newtype V = V { _V :: Value.Value }++instance CBOR.Serialise V where+ encode (V v) = Value.encode v+ decode = V <$!> Value.decode (apiNormalForm apiAPI) tyDesc++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["read" , fp] -> do x <- CBOR.readFileDeserialise fp+ _ <- evaluate (force (x :: T))+ return ()+ ["read-aeson" , fp] -> do x <- CBOR.readFileDeserialise fp+ _ <- evaluate (force (x :: JS.Value))+ return ()+ ["read-generic", fp] -> do x <- CBOR.readFileDeserialise fp+ _ <- evaluate (force (_V x))+ return ()+ ["write" ,fp] -> do x <- generate (resize 500 arbitrary)+ CBOR.writeFileSerialise fp (x :: T)+ ["write" ,fp,i] -> do x <- generate (resize (read i) arbitrary)+ CBOR.writeFileSerialise fp (x :: T)+ _ -> error "perf-test (read|read-generic|write) <file>"
src/Data/API/JSON.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-}@@ -63,10 +64,12 @@ ) where import Data.API.Error+import Data.API.Time import Data.API.Types import Data.API.Utils import Control.Applicative+import qualified Control.Monad.Fail as Fail import qualified Data.Aeson as JS import qualified Data.Aeson.Parser as JS import qualified Data.Aeson.Types as JS@@ -82,7 +85,6 @@ import Data.Traversable import qualified Data.Vector as V import Data.Version-import Distribution.Text (simpleParse) import Text.Regex import Prelude @@ -125,6 +127,11 @@ (es, Just x ) -> let (es', r) = runParserWithErrs (f x) q z in (es ++ es', r) (es, Nothing) -> (es, Nothing)+#if !(MIN_VERSION_base(4,13,0))+ fail = Fail.fail+#endif++instance Fail.MonadFail ParserWithErrs where fail = failWith . SyntaxError @@ -343,7 +350,7 @@ -> JS.Value -> ParserWithErrs a withUTC lab f = withText lab g where- g t = maybe (failWith $ BadFormat FmtUTC lab t) f $ parseUTC' t+ g t = maybe (failWith $ BadFormat FmtUTC lab t) f $ parseUTC t withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a@@ -351,7 +358,7 @@ withVersion :: String -> (Version -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a-withVersion lab f (JS.String s) = case simpleParse $ T.unpack s of+withVersion lab f (JS.String s) = case simpleParseVersion (T.unpack s) of Just ver -> f ver Nothing -> failWith $ badFormat lab s withVersion lab _ v = failWith $ Expected ExpString lab v
src/Data/API/JSONToCBOR.hs view
@@ -8,6 +8,7 @@ import Data.API.Changes import Data.API.JSON+import Data.API.Time import Data.API.Types import Data.API.Utils @@ -23,7 +24,6 @@ import Data.Binary.Serialise.CBOR.JSON (cborToJson, jsonToCbor) import Codec.CBOR.Term import Data.Fixed (Pico)-import Data.Maybe (fromMaybe) import Data.Scientific import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -114,8 +114,7 @@ | frac' < 0 -> (secs' - 1, frac' + 1) | otherwise -> (secs', frac') psecs = round $ frac * 1000000000000- utc = fromMaybe (error $ "jsonToCBORBasic: " ++ T.unpack t) $- parseUTC' t+ utc = unsafeParseUTC t (BTutc , _) -> error "serialiseJSONWithSchema: expected string" @@ -166,12 +165,12 @@ dt :: POSIXTime dt = realToFrac v0 + realToFrac psecs - in pure $! String $! mkUTC' $! forceUTCTime (posixSecondsToUTCTime dt)+ in pure $! String $! printUTC $! forceUTCTime (posixSecondsToUTCTime dt) _ -> Left $ JSONError UnexpectedField- String t -> case parseUTC' t of+ String t -> case parseUTC t of Nothing -> Left $ JSONError $ SyntaxError $ "UTC time in wrong format: " ++ T.unpack t- Just utcTime -> pure $! String $! mkUTC' $! forceUTCTime utcTime+ Just utcTime -> pure $! String $! printUTC $! forceUTCTime utcTime _ -> Left $ JSONError $ expectedObject v TyBasic _ -> pure v TyJSON -> pure v
src/Data/API/Markdown.hs view
@@ -21,8 +21,8 @@ , thing ) where +import Data.API.Time import Data.API.Types-import Data.API.Utils import qualified Data.CaseInsensitive as CI import Data.Char@@ -85,7 +85,7 @@ where f (FtrStrg RegEx{..} ) = "**filter** " ++ show re_text f (FtrIntg IntRange{..}) = "**filter** " ++ rg show ir_lo ir_hi- f (FtrUTC UTCRange{..}) = "**filter** " ++ rg mkUTC_ ur_lo ur_hi+ f (FtrUTC UTCRange{..}) = "**filter** " ++ rg (T.unpack . printUTC) ur_lo ur_hi rg _ Nothing Nothing = "**no restriction**" -- should not happen (not produced by parser) rg sh Nothing (Just hi) = "x <= " ++ sh hi@@ -200,7 +200,7 @@ DefValString t -> show t DefValBool b -> map toLower $ show b DefValInt i -> show i- DefValUtc u -> show $ mkUTC_ u+ DefValUtc u -> show $ printUTC u type_md :: MarkdownMethods -> APIType -> MDComment type_md mdm ty =
src/Data/API/Parse.y view
@@ -10,15 +10,15 @@ , apiWithChangelog ) where -import Data.API.Types-import Data.API.Scan import Data.API.Changes+import Data.API.Scan+import Data.API.Types+import Data.API.Utils import Data.Char import Data.String import qualified Data.Text as T import qualified Data.CaseInsensitive as CI import qualified Data.Version as V-import Distribution.Text (simpleParse) import Language.Haskell.TH import Language.Haskell.TH.Quote import Text.Printf@@ -348,7 +348,7 @@ parseVer :: String -> V.Version-parseVer x = case simpleParse x of+parseVer x = case simpleParseVersion x of Just v -> v Nothing -> error $ "Syntax error while parsing version " ++ x
src/Data/API/Scan.x view
@@ -9,10 +9,12 @@ , keywords ) where +import Data.API.Time import Data.API.Types import Data.API.Utils import Data.Char+import qualified Data.Text as T import Data.Time import Safe }@@ -138,7 +140,7 @@ deriving (Eq,Show) utc_ :: AlexPosn -> String -> PToken-utc_ = mk $ \s -> maybe ERROR UTCTIME $ parseUTC_ s+utc_ = mk $ \s -> maybe ERROR UTCTIME $ parseUTC (T.pack s) line_comment :: AlexPosn -> String -> PToken line_comment = mk $ Comment . munch_ws . tailSafe . tailSafe
+ src/Data/API/Time.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wwarn=orphans #-}+module Data.API.Time+ ( printUTC+ , parseUTC+ , parseDay+ , unsafeParseUTC+ , unsafeParseDay+ , parseUTC_old+ ) where++import Control.Monad+import qualified Data.Attoparsec.Text as AP+import Data.Maybe+import Data.Scientific+import qualified Data.Text as T+import Data.Time++import GHC.Stack+import Test.QuickCheck as QC++utcFormat :: String+utcFormat = "%Y-%m-%dT%H:%M:%SZ"++utcFormats :: [String]+utcFormats =+ [ "%Y-%m-%dT%H:%M:%S%Z"+ , "%Y-%m-%dT%H:%M:%S"+ , "%Y-%m-%dT%H:%M%Z"+ , "%Y-%m-%dT%H:%M"+ , "%Y-%m-%dT%H:%M:%S%QZ"+ , utcFormat+ , "%Y-%m-%d %H:%M:%S"+ , "%Y-%m-%d %H:%M:%S%Z"+ , "%Y-%m-%d %H:%M:%S%QZ"+ , "%Y-%m-%d %H:%M%Z"+ , "%Y-%m-%d %H:%M"+ ]++-- | Render a 'UTCTime' in ISO 8601 format to a precision of seconds+-- (i.e. omitting any subseconds).+printUTC :: UTCTime -> T.Text+printUTC utct = T.pack $ formatTime defaultTimeLocale utcFormat utct++-- | Parse text as a 'UTCTime' in ISO 8601 format or a number of slight+-- variations thereof (the @T@ may be replaced with a space, and the seconds,+-- milliseconds and/or @Z@ timezone indicator may optionally be omitted).+--+-- Time zone designations other than @Z@ for UTC are not currently supported.+parseUTC :: T.Text -> Maybe UTCTime+parseUTC t = case AP.parseOnly (parserUTCTime <* AP.endOfInput) t of+ Left _ -> Nothing+ Right r -> Just r++-- | Parse text as a 'Day' in @YYYY-MM-DD@ format.+parseDay :: T.Text -> Maybe Day+parseDay t = case AP.parseOnly (parserDay <* AP.endOfInput) t of+ Left _ -> Nothing+ Right r -> Just r+++parserUTCTime :: AP.Parser UTCTime+parserUTCTime = do+ day <- parserDay+ void $ AP.skip (\c -> c == ' ' || c == 'T')+ time <- parserTime+ mb_offset <- parserTimeZone+ pure (maybe id addUTCTime mb_offset $ UTCTime day time)++-- | Parser for @YYYY-MM-DD@ format.+parserDay :: AP.Parser Day+parserDay = do+ y :: Int <- AP.decimal <* AP.char '-'+ m :: Int <- AP.decimal <* AP.char '-'+ d :: Int <- AP.decimal+ case fromGregorianValid (fromIntegral y) m d of+ Just x -> pure x+ Nothing -> fail "invalid date"++-- | Parser for times in the format @HH:MM@, @HH:MM:SS@ or @HH:MM:SS.QQQ...@.+parserTime :: AP.Parser DiffTime+parserTime = do+ h :: Int <- AP.decimal+ void $ AP.char ':'+ m :: Int <- AP.decimal+ c <- AP.peekChar+ s <- case c of+ Just ':' -> AP.anyChar *> AP.scientific+ _ -> pure 0+ case toBoundedInteger (10^(12::Int) * (s + fromIntegral (60*(m + 60*h)))) of+ Just n -> pure (picosecondsToDiffTime (fromIntegral (n :: Int)))+ Nothing -> fail "seconds out of range"++-- | Parser for time zone indications such as @Z@, @ UTC@ or an explicit offset+-- like @+HH:MM@ or @-HH@. Returns 'Nothing' for UTC. Local times (without a+-- timezone designator) are assumed to be UTC. If there is an explicit offset,+-- returns its negation.+parserTimeZone :: AP.Parser (Maybe NominalDiffTime)+parserTimeZone = do+ c <- AP.option 'Z' AP.anyChar+ case c of+ 'Z' -> pure Nothing+ ' ' -> "UTC" *> pure Nothing+ '+' -> parse_offset True+ '-' -> parse_offset False+ _ -> fail "unexpected time zone character"+ where+ parse_offset pos = do+ hh :: Int <- read <$> AP.count 2 AP.digit+ AP.option () (AP.skip (== ':'))+ mm :: Int <- AP.option 0 (read <$> AP.count 2 AP.digit)+ let v = (if pos then negate else id) ((hh*60 + mm) * 60)+ return (Just (fromIntegral v))++-- | Parse text as a 'UTCTime' in ISO 8601 format or a number of slight+-- variations thereof (the @T@ may be replaced with a space, and the seconds and+-- timezone indicator may optionally be omitted).+parseUTC_old :: T.Text -> Maybe UTCTime+parseUTC_old t = stringToUTC $ T.unpack t++stringToUTC :: String -> Maybe UTCTime+stringToUTC s = listToMaybe $ catMaybes $+ map (\fmt->parseTimeM True defaultTimeLocale fmt s) utcFormats++-- | Variant of 'parseUTC' that throws an error if the input text could not be+-- parsed.+unsafeParseUTC :: HasCallStack => T.Text -> UTCTime+unsafeParseUTC t = fromMaybe (error msg) (parseUTC t)+ where+ msg = "unsafeParseUTC: unable to parse: " ++ T.unpack t++-- | Variant of 'parseDay' that throws an error if the input text could not be+-- parsed.+unsafeParseDay :: HasCallStack => T.Text -> Day+unsafeParseDay t = fromMaybe (error msg) (parseDay t)+ where+ msg = "unsafeParseDay: unable to parse: " ++ T.unpack t+++-- TODO: use a more arbitrary instance (quickcheck-instances?)+-- (in particular, there are no subsecond-resolution times here)+instance QC.Arbitrary UTCTime where+ arbitrary = QC.oneof+ [ QC.elements [mk "2010-01-01T00:00:00Z"+ , mk "2013-05-27T19:13:50Z"+ , mk "2011-07-20T22:04:00Z"+ , mk "2012-02-02T15:45:11Z"+ , mk "2009-11-12T20:57:54Z"+ , mk "2000-10-28T21:03:24Z"+ , mk "1965-03-10T09:23:01Z"+ ]]+ where+ mk = unsafeParseUTC
src/Data/API/Tools/CBOR.hs view
@@ -12,6 +12,7 @@ import Data.API.Types import Control.Applicative+import qualified Control.Monad.Fail as Fail import Codec.Serialise.Class import Codec.Serialise.Decoding import Codec.Serialise.Encoding@@ -183,7 +184,7 @@ bdy_out an = [e| decodeString >>= cborStrMap_p $(varE (map_enum_nm an)) |] -- In a monad, to @fail@ instead of crashing with @error@.-cborStrMap_p :: (Monad m, Ord a) => Map.Map T.Text a -> T.Text -> m a+cborStrMap_p :: (Fail.MonadFail m, Ord a) => Map.Map T.Text a -> T.Text -> m a cborStrMap_p mp t = case Map.lookup t mp of Nothing -> fail "Unexpected enumeration key in CBOR" Just r -> return r
src/Data/API/Tools/Enum.hs view
@@ -15,7 +15,6 @@ import qualified Data.Text as T import qualified Data.Map as Map-import Data.Monoid import Language.Haskell.TH
src/Data/API/Tools/Example.hs view
@@ -10,10 +10,10 @@ ) where import Data.API.TH+import Data.API.Time import Data.API.Tools.Combinators import Data.API.Tools.Datatypes import Data.API.Types-import Data.API.Utils import Control.Applicative import Data.Aeson@@ -21,7 +21,6 @@ import Data.Monoid import Data.Time import Language.Haskell.TH-import Safe import Test.QuickCheck as QC import qualified Data.Text as T import Prelude@@ -59,9 +58,7 @@ example = return $ String "an example JSON value" instance Example UTCTime where- example = return $ fromJustNote dg $ parseUTC_ "2013-06-09T15:52:30Z"- where- dg = "Data.API.Tools.Example-UTCTime"+ example = return $ unsafeParseUTC "2013-06-09T15:52:30Z" -- | Generate a list of (type name, sample generator) pairs
src/Data/API/Tools/JSON.hs view
@@ -14,7 +14,6 @@ import Data.API.Tools.Datatypes import Data.API.Tools.Enum import Data.API.Types-import Data.API.Utils import Data.Aeson hiding (withText, withBool) import Control.Applicative@@ -77,7 +76,7 @@ BTbinary -> [e| toJSON |] BTbool -> [e| Bool |] BTint -> [e| mkInt |]- BTutc -> [e| mkUTC |]+ BTutc -> [e| String . printUTC |] {-
src/Data/API/Tools/QuickCheck.hs view
@@ -1,22 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -fno-warn-orphans #-} module Data.API.Tools.QuickCheck ( quickCheckTool ) where import Data.API.TH+import Data.API.Time () import Data.API.Tools.Combinators import Data.API.Tools.Datatypes import Data.API.Types-import Data.API.Utils import Control.Applicative import Data.Monoid import Data.Time import Language.Haskell.TH-import Safe import Test.QuickCheck as QC import Prelude @@ -109,22 +107,3 @@ arbitraryUTCRange (UTCRange Nothing (Just hi)) = pure hi arbitraryUTCRange (UTCRange (Just lo) (Just hi)) = QC.elements [lo, hi] arbitraryUTCRange (UTCRange Nothing Nothing ) = QC.arbitrary---- TODO: use a more arbitrary instance (quickcheck-instances?)--- (in particular, there are no subsecond-resolution times here)-instance QC.Arbitrary UTCTime where- arbitrary = QC.elements- [ mk "2010-01-01T00:00:00Z"- , mk "2013-05-27T19:13:50Z"- , mk "2011-07-20T22:04:00Z"- , mk "2012-02-02T15:45:11Z"- , mk "2009-11-12T20:57:54Z"- , mk "2000-10-28T21:03:24Z"- , mk "1965-03-10T09:23:01Z"- -- , mk "1965-03-10T09:23:01.001Z"- -- , mk "1965-03-10T09:23:01.000001Z"- ]- where- mk = fromJustNote lab . parseUTC'-- lab = "Data.API.Tools.QuickCheck.Arbitrary-UTCTime"
src/Data/API/Types.hs view
@@ -1,4 +1,6 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveLift #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-}@@ -34,7 +36,7 @@ , base64ToBinary ) where -import Data.API.Utils+import Data.API.Time import Control.DeepSeq import qualified Data.CaseInsensitive as CI@@ -66,7 +68,7 @@ data Thing = ThComment MDComment | ThNode APINode- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData Thing where rnf (ThComment x) = rnf x@@ -120,7 +122,7 @@ | SpUnion SpecUnion | SpEnum SpecEnum | SpSynonym APIType- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData Spec where rnf (SpNewtype x) = rnf x@@ -136,7 +138,7 @@ { snType :: BasicType , snFilter :: Maybe Filter }- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData SpecNewtype where rnf (SpecNewtype x y) = rnf x `seq` rnf y@@ -145,7 +147,7 @@ = FtrStrg RegEx | FtrIntg IntRange | FtrUTC UTCRange- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData Filter where rnf (FtrStrg x) = rnf x@@ -157,7 +159,7 @@ { ir_lo :: Maybe Int , ir_hi :: Maybe Int }- deriving (Eq, Show)+ deriving (Eq, Lift, Show) instance NFData IntRange where rnf (IntRange x y) = rnf x `seq` rnf y@@ -214,7 +216,7 @@ data SpecRecord = SpecRecord { srFields :: [(FieldName, FieldType)] }- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData SpecRecord where rnf (SpecRecord x) = rnf x@@ -229,7 +231,7 @@ , ftDefault :: Maybe DefaultValue , ftComment :: MDComment }- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData FieldType where rnf (FieldType a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d@@ -239,7 +241,7 @@ data SpecUnion = SpecUnion { suFields :: [(FieldName,(APIType,MDComment))] }- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData SpecUnion where rnf (SpecUnion x) = rnf x@@ -249,7 +251,7 @@ data SpecEnum = SpecEnum { seAlts :: [(FieldName,MDComment)] }- deriving (Eq,Show)+ deriving (Eq,Lift,Show) instance NFData SpecEnum where rnf (SpecEnum x) = rnf x@@ -266,7 +268,7 @@ | TyName TypeName -- ^ the referenced type must be defined by the API | TyBasic BasicType -- ^ a JSON string, int, bool etc. | TyJSON -- ^ a generic JSON value- deriving (Eq, Show)+ deriving (Eq, Lift, Show) -- | It is sometimes helpful to write a type name directly as a string instance IsString APIType where@@ -286,7 +288,7 @@ | BTbool -- ^ a JSON bool | BTint -- ^ a JSON integral number | BTutc -- ^ a JSON UTC string- deriving (Eq, Show)+ deriving (Eq, Lift, Show) instance NFData BasicType where rnf !_ = ()@@ -318,7 +320,7 @@ defaultValueAsJsValue (DefValString s) = String s defaultValueAsJsValue (DefValBool b) = Bool b defaultValueAsJsValue (DefValInt n) = Number (fromIntegral n)-defaultValueAsJsValue (DefValUtc t) = mkUTC t+defaultValueAsJsValue (DefValUtc t) = String (printUTC t) -- | Binary data is represented in JSON format as a base64-encoded@@ -349,104 +351,98 @@ base64ToBinary :: T.Text -> Either String Binary base64ToBinary t = Binary <$> B64.decode (T.encodeUtf8 t) -$(deriveSafeCopy 0 'base ''Binary) -deriveJSON defaultOptions ''Thing-deriveJSON defaultOptions ''APINode-deriveJSON defaultOptions ''TypeName-deriveJSON defaultOptions ''FieldName-deriveJSON defaultOptions ''Spec-deriveJSON defaultOptions ''APIType-deriveJSON defaultOptions ''DefaultValue-deriveJSON defaultOptions ''SpecEnum-deriveJSON defaultOptions ''SpecUnion-deriveJSON defaultOptions ''SpecRecord-deriveJSON defaultOptions ''FieldType-deriveJSON defaultOptions ''SpecNewtype-deriveJSON defaultOptions ''Filter-deriveJSON defaultOptions ''IntRange-deriveJSON defaultOptions ''UTCRange-deriveJSON defaultOptions ''BasicType-deriveJSON defaultOptions ''CI.CI---instance Lift Thing where- lift (ThComment c) = [e| ThComment c |]- lift (ThNode n) = [e| ThNode n |]- instance Lift APINode where lift (APINode a b c d e) = [e| APINode a b $(liftPrefix c) d e |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped (APINode a b c d e) = [e|| APINode a b $$(liftTypedPrefix c) d e ||]+#endif liftPrefix :: Prefix -> ExpQ liftPrefix ci = let s = CI.original ci in [e| CI.mk s |] -instance Lift TypeName where- lift (TypeName s) = [e| TypeName $(litE (stringL (T.unpack s))) |]--instance Lift FieldName where- lift (FieldName s) = [e| FieldName $(litE (stringL (T.unpack s))) |]--instance Lift Spec where- lift (SpNewtype s) = [e| SpNewtype s |]- lift (SpRecord s) = [e| SpRecord s |]- lift (SpUnion s) = [e| SpUnion s |]- lift (SpEnum s) = [e| SpEnum s |]- lift (SpSynonym s) = [e| SpSynonym s |]--instance Lift SpecNewtype where- lift (SpecNewtype a b) = [e| SpecNewtype a b |]--instance Lift Filter where- lift (FtrStrg re) = [e| FtrStrg re |]- lift (FtrIntg ir) = [e| FtrIntg ir |]- lift (FtrUTC ur) = [e| FtrUTC ur |]--instance Lift IntRange where- lift (IntRange lo hi) = [e| IntRange lo hi |]--instance Lift UTCRange where- lift (UTCRange lo hi) = [e| UTCRange $(liftMaybeUTCTime lo) $(liftMaybeUTCTime hi) |]+liftText :: T.Text -> ExpQ+liftText s = [e| T.pack $(litE (stringL (T.unpack s))) |] liftUTC :: UTCTime -> ExpQ-liftUTC u = [e| fromMaybe (error "liftUTC") (parseUTC_ $(stringE (mkUTC_ u))) |]+liftUTC u = [e| unsafeParseUTC $(liftText (printUTC u)) |] liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing = [e| Nothing |] liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |] -instance Lift RegEx where- lift re = [e| mkRegEx $(stringE (T.unpack (re_text re))) |]+#if MIN_VERSION_template_haskell(2,16,0)+liftTypedPrefix :: Prefix -> TExpQ Prefix+liftTypedPrefix ci = let s = CI.original ci in [e|| CI.mk s ||] -instance Lift SpecRecord where- lift (SpecRecord s) = [e| SpecRecord s |]+liftTypedText :: T.Text -> TExpQ T.Text+liftTypedText s = [e|| T.pack $$(liftTyped (T.unpack s)) ||] -instance Lift FieldType where- lift (FieldType a b c d) = [e| FieldType a b c d |]+liftTypedUTC :: UTCTime -> TExpQ UTCTime+liftTypedUTC u = [e|| unsafeParseUTC $$(liftTypedText (printUTC u)) ||] -instance Lift SpecUnion where- lift (SpecUnion s) = [e| SpecUnion s |]+liftTypedMaybeUTCTime :: Maybe UTCTime -> TExpQ (Maybe UTCTime)+liftTypedMaybeUTCTime Nothing = [e|| Nothing ||]+liftTypedMaybeUTCTime (Just u) = [e|| Just $$(liftTypedUTC u) ||]+#endif -instance Lift SpecEnum where- lift (SpecEnum s) = [e| SpecEnum s |]+instance Lift TypeName where+ lift (TypeName s) = [e| TypeName $(liftText s) |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped (TypeName s) = [e|| TypeName $$(liftTypedText s) ||]+#endif -instance Lift APIType where- lift (TyList t) = [e| TyList t |]- lift (TyMaybe t) = [e| TyMaybe t |]- lift (TyName t) = [e| TyName t |]- lift (TyBasic t) = [e| TyBasic t |]- lift TyJSON = [e| TyJSON |]+instance Lift FieldName where+ lift (FieldName s) = [e| FieldName $(liftText s) |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped (FieldName s) = [e|| FieldName $$(liftTypedText s) ||]+#endif -instance Lift BasicType where- lift BTstring = [e| BTstring |]- lift BTbinary = [e| BTbinary |]- lift BTbool = [e| BTbool |]- lift BTint = [e| BTint |]- lift BTutc = [e| BTutc |]+instance Lift UTCRange where+ lift (UTCRange lo hi) = [e| UTCRange $(liftMaybeUTCTime lo) $(liftMaybeUTCTime hi) |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped (UTCRange lo hi) = [e|| UTCRange $$(liftTypedMaybeUTCTime lo) $$(liftTypedMaybeUTCTime hi) ||]+#endif +instance Lift RegEx where+ lift re = [e| mkRegEx $(liftText (re_text re)) |]+#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped re = [e|| mkRegEx $$(liftTypedText (re_text re)) ||]+#endif+ instance Lift DefaultValue where- lift DefValList = [e| DefValList |]- lift DefValMaybe = [e| DefValMaybe |]- lift (DefValString s) = [e| DefValString (T.pack $(lift (T.unpack s))) |]- lift (DefValBool b) = [e| DefValBool b |]- lift (DefValInt i) = [e| DefValInt i |]+ lift DefValList = [e| DefValList |]+ lift DefValMaybe = [e| DefValMaybe |]+ lift (DefValString s) = [e| DefValString $(liftText s) |]+ lift (DefValBool b) = [e| DefValBool b |]+ lift (DefValInt i) = [e| DefValInt i |] lift (DefValUtc u) = [e| DefValUtc $(liftUTC u) |]++#if MIN_VERSION_template_haskell(2,16,0)+ liftTyped DefValList = [e|| DefValList ||]+ liftTyped DefValMaybe = [e|| DefValMaybe ||]+ liftTyped (DefValString s) = [e|| DefValString $$(liftTypedText s) ||]+ liftTyped (DefValBool b) = [e|| DefValBool b ||]+ liftTyped (DefValInt i) = [e|| DefValInt i ||]+ liftTyped (DefValUtc u) = [e|| DefValUtc $$(liftTypedUTC u) ||]+#endif++$(deriveSafeCopy 0 'base ''Binary)++$(deriveJSON defaultOptions ''Thing)+$(deriveJSON defaultOptions ''APINode)+$(deriveJSON defaultOptions ''TypeName)+$(deriveJSON defaultOptions ''FieldName)+$(deriveJSON defaultOptions ''Spec)+$(deriveJSON defaultOptions ''APIType)+$(deriveJSON defaultOptions ''DefaultValue)+$(deriveJSON defaultOptions ''SpecEnum)+$(deriveJSON defaultOptions ''SpecUnion)+$(deriveJSON defaultOptions ''SpecRecord)+$(deriveJSON defaultOptions ''FieldType)+$(deriveJSON defaultOptions ''SpecNewtype)+$(deriveJSON defaultOptions ''Filter)+$(deriveJSON defaultOptions ''IntRange)+$(deriveJSON defaultOptions ''UTCRange)+$(deriveJSON defaultOptions ''BasicType)+$(deriveJSON defaultOptions ''CI.CI)
src/Data/API/Utils.hs view
@@ -1,10 +1,5 @@-{-# LANGUAGE CPP #-} module Data.API.Utils- ( mkUTC- , mkUTC'- , mkUTC_- , parseUTC'- , parseUTC_+ ( simpleParseVersion , (?!) , (?!?) -- * Utils for merging and diffing maps@@ -14,46 +9,15 @@ , matchMaps ) where -import Data.Aeson import Data.Map ( Map ) import qualified Data.Map as Map-import Data.Maybe-import qualified Data.Text as T-import Data.Time--#if MIN_VERSION_time(1,5,0)-#else-import System.Locale (defaultTimeLocale)-#endif---mkUTC :: UTCTime -> Value-mkUTC = String . mkUTC'--utcFormat :: String-utcFormat = "%Y-%m-%dT%H:%M:%SZ"--utcFormats :: [String]-utcFormats =- [ "%Y-%m-%dT%H:%M:%S%z"- , "%Y-%m-%dT%H:%M:%S%Z"- , "%Y-%m-%dT%H:%M%Z"- , "%Y-%m-%dT%H:%M:%S%QZ"- , utcFormat- ]--mkUTC' :: UTCTime -> T.Text-mkUTC' = T.pack . mkUTC_--mkUTC_ :: UTCTime -> String-mkUTC_ utct = formatTime defaultTimeLocale utcFormat utct--parseUTC' :: T.Text -> Maybe UTCTime-parseUTC' t = parseUTC_ $ T.unpack t+import Data.Version+import qualified Text.ParserCombinators.ReadP as ReadP -parseUTC_ :: String -> Maybe UTCTime-parseUTC_ s = listToMaybe $ catMaybes $- map (\fmt->parseTime defaultTimeLocale fmt s) utcFormats+simpleParseVersion :: String -> Maybe Version+simpleParseVersion s = case filter (null . snd) (ReadP.readP_to_S parseVersion s) of+ [(v,_)] -> Just v+ _ -> Nothing -- | The \"oh noes!\" operator.
src/Data/API/Value.hs view
@@ -47,6 +47,7 @@ import Data.API.Error import Data.API.JSON import Data.API.NormalForm+import Data.API.Time import Data.API.Types import Data.API.Utils @@ -166,7 +167,7 @@ instance JS.ToJSON Value where toJSON v0 = case v0 of String t -> JS.String t- UTCTime t -> JS.String (mkUTC' t)+ UTCTime t -> JS.String (printUTC t) Bytes b -> JS.toJSON b Bool b -> JS.Bool b Int i -> JS.toJSON i
src/Data/Binary/Serialise/CBOR/Extra.hs view
@@ -14,7 +14,6 @@ import Codec.Serialise.Decoding import Codec.Serialise.Encoding import Data.List (foldl1')-import Data.Monoid import qualified Data.Text as T #if MIN_VERSION_base(4,8,0)
tests/Data/API/Test/Gen.hs view
@@ -9,12 +9,14 @@ import Data.API.Test.DSL hiding (example) import qualified Data.API.Test.DSL as DSL+import Data.API.Time import Data.API.Tools import Data.API.Tools.Datatypes import Data.API.Tools.Example import Data.API.Value ( arbitraryJSONValue ) import Control.Applicative+import qualified Control.Monad.Fail as Fail import qualified Data.Aeson as JS import Data.SafeCopy import GHC.Generics@@ -82,7 +84,7 @@ instance Example CHOICE -inj_chc :: Monad m => REP__CHOICE -> m CHOICE+inj_chc :: Fail.MonadFail m => REP__CHOICE -> m CHOICE inj_chc (CHC_a i) = return $ CHOICE i inj_chc (CHC_b _) = fail "no choice"
tests/Data/API/Test/JSON.hs view
@@ -15,13 +15,12 @@ import Data.API.Test.DSL import Data.API.Test.Gen hiding ( Foo ) import Data.API.Test.MigrationData+import Data.API.Time import Data.API.Types-import Data.API.Utils import qualified Data.API.Value as Value import qualified Data.Aeson as JS import qualified Data.HashMap.Strict as HMap-import Data.Time import Test.Tasty import Test.Tasty.HUnit@@ -55,7 +54,7 @@ True , help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True , help' noFilter (JS.String "cabcage") (UnsafeMkFilteredString "cabcage") True- , help' noFilter (JS.String "2014-10-13T15:20:10Z") (UnsafeMkFilteredUTC (pUTC "2014-10-13T15:20:10Z")) True+ , help' noFilter (JS.String "2014-10-13T15:20:10Z") (UnsafeMkFilteredUTC (unsafeParseUTC "2014-10-13T15:20:10Z")) True ] where help v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x)@@ -88,7 +87,7 @@ , help "string mismatch" "[\"cabcage\"]" (proxy :: [FilteredString]) [(RegexError "FilteredString" "cabcage" (mkRegEx "cab*age"), [InElem 0])] , help "utc out of range" "[\"2014-10-13T15:20:10Z\"]" (proxy :: [FilteredUTC])- [(UTCRangeError "FilteredUTC" (pUTC "2014-10-13T15:20:10Z") (UTCRange (parseUTC_ "2014-10-13T15:20:11Z") Nothing), [InElem 0])]+ [(UTCRangeError "FilteredUTC" (unsafeParseUTC "2014-10-13T15:20:10Z") (UTCRange (parseUTC "2014-10-13T15:20:11Z") Nothing), [InElem 0])] ] where proxy = error "proxy"@@ -111,11 +110,8 @@ mkFilteredString "cabbage" @?= Just (UnsafeMkFilteredString "cabbage") ] where- bad_time = pUTC "2014-10-13T15:20:10Z"- good_time = pUTC "2014-10-13T15:20:13Z"--pUTC :: String -> UTCTime-pUTC = maybe (error "pUTC") id . parseUTC_+ bad_time = unsafeParseUTC "2014-10-13T15:20:10Z"+ good_time = unsafeParseUTC "2014-10-13T15:20:13Z" jsonTests :: TestTree jsonTests = testGroup "JSON"
tests/Data/API/Test/Main.hs view
@@ -1,11 +1,8 @@-module Data.API.Test.Main- ( main- ) where- import Data.API.API import Data.API.API.Gen import Data.API.Test.JSON import Data.API.Test.Migration+import Data.API.Test.Time import Test.Tasty import Test.Tasty.QuickCheck@@ -16,6 +13,7 @@ tests :: TestTree tests = testGroup "api-tools" [ migrationTests , jsonTests+ , timeTests , testProperty "Convert/unconvert" convertUncovertTest ]
tests/Data/API/Test/MigrationData.hs view
@@ -10,12 +10,12 @@ import Data.API.JSON import Data.API.Parse import Data.API.Types+import Data.API.Utils import qualified Data.Aeson as JS import qualified Data.Set as Set import qualified Data.Text as T import Data.Version-import Distribution.Text (simpleParse) startSchema :: API@@ -520,8 +520,8 @@ ] where toVersions (s, s', x)- | Just v <- simpleParse s- , Just v' <- simpleParse s'+ | Just v <- simpleParseVersion s+ , Just v' <- simpleParseVersion s' , v < v' = (v, v', x) | otherwise = error $ "expectedApplyFailures: bad versions " ++ show s ++ " and " ++ show s'@@ -572,7 +572,7 @@ ) ] where- ver s | Just v <- simpleParse s = v+ ver s | Just v <- simpleParseVersion s = v | otherwise = error $ "expectedValidateFailures: bad version " ++ show s verRelease s = Release $ ver s
+ tests/Data/API/Test/Time.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.API.Test.Time (timeTests) where++import Data.API.Time++import Data.Time+import qualified Data.Text as T+import Test.Tasty+import qualified Test.Tasty.QuickCheck as QC++timeTests :: TestTree+timeTests = testGroup "Time" [ QC.testProperty "parseUTC/printUTC round-trip" parseUTCPrintUTC+ , QC.testProperty "parseUTC/show round-trip" parseUTCShow+ , QC.testProperty "parseUTC/parseUTC_old agreement" parseUTCReference+ ]++-- | 'printUTC' drops the fractional seconds, so check that 'parseUTC' of its+-- result is the same up to removing them.+parseUTCPrintUTC :: QC.Property+parseUTCPrintUTC = QC.forAll moreArbitraryUTCTime $ \u -> parseUTC (printUTC u) QC.=== Just (stripFractionalSeconds u)++-- | 'show' does not drop the fractional seconds, so check that 'parseUTC' of+-- its result is the original time.+parseUTCShow :: QC.Property+parseUTCShow = QC.forAll moreArbitraryUTCTime $ \u -> parseUTC (T.pack (show u)) QC.=== Just u++stripFractionalSeconds :: UTCTime -> UTCTime+stripFractionalSeconds (UTCTime d t) = UTCTime d (fromIntegral (floor t :: Integer))+++-- | Test that the reference implementation and optimized implementation of+-- 'parseUTC' agree on a variety of inputs.+--+-- Note that the optimized implementation is more permissive, where out-of-range+-- times are supplied (e.g. it allows seconds to exceed 60).+parseUTCReference :: QC.Property+parseUTCReference = QC.forAll genTimestamp (\ s -> parseUTC s QC.=== parseUTC_old s)++-- | Generate a (roughly) ISO 8601 format data/time string.+genTimestamp :: QC.Gen T.Text+genTimestamp = do+ day <- fromGregorian <$> QC.choose (1999,2100) <*> QC.choose (1,12) <*> QC.choose(1,31)+ sep <- QC.elements [" ", "T"]+ hh <- gen_hh+ mm <- gen_mm+ mb_ss <- gen_ss+ tz <- QC.oneof [ pure "", pure "Z", gen_tz_offset ]+ pure (T.pack (show day ++ sep ++ hh ++ ":" ++ mm ++ maybe "" (":" ++) mb_ss ++ tz))+ where+ gen_hh = pad2 . show <$> QC.choose (0,23 :: Int)+ gen_mm = pad2 . show <$> QC.choose (0,59 :: Int)+ gen_ss = fmap (pad2 . show) <$> QC.oneof [Just <$> QC.choose (0,59 :: Int), pure Nothing]++ -- Either + or - followed by one of HH:MM or HHMM+ -- (the new implementation accepts just HH too, but the old one did not)+ gen_tz_offset = do+ sign <- QC.elements ["+","-"]+ hh <- gen_hh+ sep <- QC.elements [":", ""]+ mm <- gen_mm+ pure (sign ++ hh ++ sep ++ mm)++ pad2 [c] = ['0',c]+ pad2 cs = cs++-- | The @Arbitrary UTCTime@ instance defined in 'Data.API.Time' does not+-- generate subsecond-resolution times, whereas this generator does.+moreArbitraryUTCTime :: QC.Gen UTCTime+moreArbitraryUTCTime =+ QC.oneof [ QC.arbitrary+ , QC.elements [ unsafeParseUTC "1965-03-10T09:23:01.001Z"+ , unsafeParseUTC "1965-03-10T09:23:01.000001Z"+ ]+ , UTCTime <$> arbitraryDay <*> arbitraryDiffTime+ ]+ where+ arbitraryDay = fromGregorian <$> QC.choose (1999,2100) <*> QC.choose (1,12) <*> QC.choose(1,31)+ arbitraryDiffTime = picosecondsToDiffTime <$> QC.choose (0, 86401*10^(12 :: Int))