api-tools (empty) → 0.2
raw patch · 38 files changed
+6671/−0 lines, 38 filesdep +Cabaldep +QuickCheckdep +aesonsetup-changed
Dependencies added: Cabal, QuickCheck, aeson, aeson-pretty, api-tools, array, attoparsec, base, base64-bytestring, bytestring, case-insensitive, containers, lens, old-locale, regex-compat-tdfa, safe, safecopy, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, time, unordered-containers, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- api-tools.cabal +173/−0
- main/Data/API/MigrationTool.hs +98/−0
- src/Data/API/API.hs +219/−0
- src/Data/API/API/DSL.hs +163/−0
- src/Data/API/API/Gen.hs +27/−0
- src/Data/API/Changes.hs +1262/−0
- src/Data/API/Doc.hs +21/−0
- src/Data/API/Doc/Call.hs +297/−0
- src/Data/API/Doc/Dir.hs +111/−0
- src/Data/API/Doc/Subst.hs +40/−0
- src/Data/API/Doc/Types.hs +117/−0
- src/Data/API/JSON.hs +415/−0
- src/Data/API/Markdown.hs +250/−0
- src/Data/API/PP.hs +91/−0
- src/Data/API/Parse.y +368/−0
- src/Data/API/Scan.x +192/−0
- src/Data/API/TH.hs +59/−0
- src/Data/API/Tools.hs +62/−0
- src/Data/API/Tools/Combinators.hs +102/−0
- src/Data/API/Tools/Datatypes.hs +207/−0
- src/Data/API/Tools/Enum.hs +83/−0
- src/Data/API/Tools/Example.hs +141/−0
- src/Data/API/Tools/JSON.hs +244/−0
- src/Data/API/Tools/JSONTests.hs +54/−0
- src/Data/API/Tools/Lens.hs +19/−0
- src/Data/API/Tools/QuickCheck.hs +126/−0
- src/Data/API/Tools/SafeCopy.hs +20/−0
- src/Data/API/Tutorial.hs +269/−0
- src/Data/API/Types.hs +295/−0
- src/Data/API/Utils.hs +55/−0
- tests/Data/API/Test/DSL.hs +92/−0
- tests/Data/API/Test/Gen.hs +101/−0
- tests/Data/API/Test/JSON.hs +84/−0
- tests/Data/API/Test/Main.hs +16/−0
- tests/Data/API/Test/Migration.hs +160/−0
- tests/Data/API/Test/MigrationData.hs +606/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013-2014, Iris Connect++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Iris Connect nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ api-tools.cabal view
@@ -0,0 +1,173 @@+Name: api-tools+Version: 0.2+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+ corresponding data types and assorted tools for+ working with it, including Aeson and QuickCheck+ instances for converting between JSON and the+ generated types and writing unit tests.+Homepage: http://github.com/iconnect/api-tools+License: BSD3+License-file: LICENSE+Author: Chris Dornan <chrisd@irisconnect.co.uk> and Adam Gundry <adam@well-typed.com>+Maintainer: Chris Dornan <chrisd@irisconnect.co.uk>+Copyright: (c) Iris Connect 2013-2014+Category: Network, Web, Cloud, Distributed Computing+Build-type: Simple++Cabal-version: >=1.10++Library+ Hs-Source-Dirs: src++ Exposed-modules:+ Data.API.API+ Data.API.API.Gen+ Data.API.Changes+ Data.API.Doc+ Data.API.Doc.Subst+ Data.API.JSON+ Data.API.Markdown+ Data.API.Parse+ Data.API.PP+ Data.API.Tools+ Data.API.Tools.Combinators+ Data.API.Tools.Datatypes+ Data.API.Tools.Enum+ Data.API.Tools.Example+ Data.API.Tools.JSON+ Data.API.Tools.JSONTests+ Data.API.Tools.Lens+ Data.API.Tools.QuickCheck+ Data.API.Tools.SafeCopy+ Data.API.Tutorial+ Data.API.Types+ Data.API.Utils++ Other-modules:+ Data.API.API.DSL+ Data.API.Doc.Call+ Data.API.Doc.Dir+ Data.API.Doc.Types+ Data.API.Scan+ Data.API.TH++ Build-depends:+ Cabal >= 1.9.2 ,+ QuickCheck >= 2.5.1,+ aeson >= 0.6.2 && < 0.7,+ aeson-pretty <= 0.7 ,+ array >= 0.4,+ attoparsec >= 0.10.4,+ base == 4.*,+ base64-bytestring == 1.0.*,+ bytestring >= 0.9 && < 0.11,+ case-insensitive >= 1.0,+ containers >= 0.5,+ lens >= 3.8.7,+ old-locale >= 1.0.0.4,+ regex-compat-tdfa >= 0.95.1,+ safe >= 0.3.3,+ safecopy >= 0.8.1,+ time >= 1.4,+ template-haskell >= 2.7,+ text >= 0.11,+ unordered-containers >= 0.2.3.0 ,+ vector >= 0.10.0.1++ Build-tools:+ alex,+ happy++ GHC-Options:+ -Wall+ -fwarn-tabs++ Default-Language: Haskell2010+++Executable migration-tool+ Hs-Source-Dirs: main++ Main-is: Data/API/MigrationTool.hs++ Build-depends:+ api-tools == 0.2,+ Cabal >= 1.9.2 ,+ QuickCheck >= 2.5.1,+ aeson >= 0.6.2 && < 0.7,+ aeson-pretty <= 0.7 ,+ array >= 0.4,+ attoparsec >= 0.10.4,+ base == 4.*,+ base64-bytestring == 1.0.*,+ bytestring >= 0.9 && < 0.11,+ case-insensitive >= 1.0,+ containers >= 0.5,+ lens >= 3.8.7,+ old-locale >= 1.0.0.4,+ regex-compat-tdfa >= 0.95.1,+ safe >= 0.3.3,+ safecopy >= 0.8.1,+ time >= 1.4,+ template-haskell >= 2.7,+ text >= 0.11,+ unordered-containers >= 0.2.3.0 ,+ vector >= 0.10.0.1++ GHC-Options:+ -main-is Data.API.MigrationTool+ -Wall+ -fwarn-tabs++ Default-Language: Haskell2010+++Test-Suite test-api-tools+ Hs-Source-Dirs: tests++ Type: exitcode-stdio-1.0++ Main-is: Data/API/Test/Main.hs++ Other-modules:+ Data.API.Test.DSL+ Data.API.Test.Gen+ Data.API.Test.JSON+ Data.API.Test.Migration+ Data.API.Test.MigrationData++ Build-depends:+ api-tools == 0.2,+ Cabal >= 1.9.2 ,+ QuickCheck >= 2.5.1,+ aeson >= 0.6.2 && < 0.7,+ aeson-pretty <= 0.7 ,+ array >= 0.4,+ attoparsec >= 0.10.4,+ base == 4.*,+ base64-bytestring == 1.0.*,+ bytestring >= 0.9 && < 0.11,+ case-insensitive >= 1.0,+ containers >= 0.5,+ lens >= 3.8.7,+ old-locale >= 1.0.0.4,+ regex-compat-tdfa >= 0.95.1,+ safe >= 0.3.3,+ safecopy >= 0.8.1,+ tasty >= 0.3 ,+ tasty-hunit >= 0.2 ,+ tasty-quickcheck >= 0.3 ,+ time >= 1.4,+ template-haskell >= 2.7,+ text >= 0.11,+ unordered-containers >= 0.2.3.0 ,+ vector >= 0.10.0.1++ GHC-Options:+ -main-is Data.API.Test.Main+ -Wall+ -fwarn-tabs++ Default-Language: Haskell2010
+ main/Data/API/MigrationTool.hs view
@@ -0,0 +1,98 @@+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 (readFile file)++data ChangeTag = None+ deriving (Read, Show)++customMigrations :: CustomMigrations ChangeTag ChangeTag ChangeTag+customMigrations = CustomMigrations nope (\ _ _ -> Nothing)+ nope (\ _ _ -> Nothing)+ nofld+ where+ nope _ v = Left (CustomMigrationError "No custom migrations defined" (JS.Object v))+ nofld _ v = Left (CustomMigrationError "No field custom migrations defined" 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 s)
+ src/Data/API/API.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | This module converts an API specified with the DSL into a+-- JSON-encoded object so that it can be used in clients.+module Data.API.API+ ( apiAPI+ , extractAPI+ ) where++import Data.API.API.DSL+import qualified Data.API.API.Gen as D+import Data.API.Types+import Data.API.JSON++import Data.Aeson+import qualified Data.CaseInsensitive as CI+import qualified Data.Text as T+import Control.Applicative+import Text.Regex+++-- | Take an API spec and generate a JSON description of the API++extractAPI :: API -> Value+extractAPI api = toJSON $ map convert [ an | ThNode an <- api ]++convert :: APINode -> D.APINode+convert (APINode{..}) =+ D.APINode+ { D._an_name = T.pack $ _TypeName anName+ , D._an_comment = T.pack anComment+ , D._an_prefix = T.pack $ CI.original anPrefix+ , D._an_spec = convert_spec anSpec+ , D._an_convert = fmap convert_conversion anConvert+ }++convert_spec :: Spec -> D.Spec+convert_spec sp =+ case sp of+ SpNewtype sn -> D.SP_newtype $ convert_specnt sn+ SpRecord sr -> D.SP_record $ convert_fields $ srFields sr+ SpUnion su -> D.SP_union $ convert_union $ suFields su+ SpEnum se -> D.SP_enum $ convert_alts $ seAlts se+ SpSynonym ty -> D.SP_synonym $ convert_type ty++convert_conversion :: (FieldName,FieldName) -> D.Conversion+convert_conversion (i,p) =+ D.Conversion+ { D._cv_injection = T.pack $ _FieldName p+ , D._cv_projection = T.pack $ _FieldName i+ }++convert_specnt :: SpecNewtype -> D.SpecNewtype+convert_specnt sn =+ D.SpecNewtype+ { D._sn_type = convert_basic $ snType sn+ , D._sn_filter = convert_filter <$> snFilter sn+ }++convert_filter :: Filter -> D.Filter+convert_filter ftr =+ case ftr of+ FtrStrg RegEx{..} -> D.FT_string $ D.RegularExpression re_text+ FtrIntg IntRange{..} -> D.FT_integer $ D.IntRange ir_lo ir_hi+ FtrUTC UTCRange{..} -> D.FT_utc $ D.UTCRange ur_lo ur_hi++convert_fields :: [(FieldName, FieldType)] -> [D.Field]+convert_fields al = map f al+ where+ f (fn,fty) =+ D.Field+ { D._fd_name = T.pack $ _FieldName fn+ , D._fd_type = convert_type $ ftType fty+ , D._fd_readonly = ftReadOnly fty+ , D._fd_default = convert_default <$> ftDefault fty+ , D._fd_comment = T.pack $ ftComment fty+ }++convert_union :: [(FieldName, (APIType, MDComment))] -> [D.Field]+convert_union al = map f al+ where+ f (fn,(ty,co)) =+ D.Field+ { D._fd_name = T.pack $ _FieldName fn+ , D._fd_type = convert_type ty+ , D._fd_readonly = False+ , D._fd_default = Nothing+ , D._fd_comment = T.pack co+ }++convert_alts :: [(FieldName,MDComment)] -> [T.Text]+convert_alts fns = map (T.pack . _FieldName . fst) fns++convert_type :: APIType -> D.APIType+convert_type ty0 =+ case ty0 of+ TyList ty -> D.TY_list $ convert_type ty+ TyMaybe ty -> D.TY_maybe $ convert_type ty+ TyName tn -> D.TY_ref $ convert_ref tn+ TyBasic bt -> D.TY_basic $ convert_basic bt+ TyJSON -> D.TY_json 0++convert_ref :: TypeName -> D.TypeRef+convert_ref (TypeName tn) = D.TypeRef (T.pack tn)++convert_basic :: BasicType -> D.BasicType+convert_basic bt =+ case bt of+ BTstring -> D.BT_string+ BTbinary -> D.BT_binary+ BTbool -> D.BT_boolean+ BTint -> D.BT_integer+ BTutc -> D.BT_utc++convert_default :: DefaultValue -> D.DefaultValue+convert_default DefValList = D.DV_list 0+convert_default DefValMaybe = D.DV_maybe 0+convert_default (DefValString s) = D.DV_string s+convert_default (DefValBool b) = D.DV_boolean b+convert_default (DefValInt i) = D.DV_integer i+convert_default (DefValUtc u) = D.DV_utc u++++-- | Generate an API spec from the JSON++instance FromJSONWithErrs Thing where+ parseJSONWithErrs v = (ThNode . unconvert) <$> parseJSONWithErrs v++unconvert :: D.APINode -> APINode+unconvert (D.APINode{..}) =+ APINode+ { anName = TypeName $ T.unpack _an_name+ , anComment = T.unpack _an_comment+ , anPrefix = CI.mk $ T.unpack _an_prefix+ , anSpec = unconvert_spec _an_spec+ , anConvert = fmap unconvert_conversion _an_convert+ }++unconvert_spec :: D.Spec -> Spec+unconvert_spec sp =+ case sp of+ D.SP_newtype sn -> SpNewtype $ unconvert_specnt sn+ D.SP_record sr -> SpRecord $ SpecRecord $ unconvert_fields sr+ D.SP_union su -> SpUnion $ SpecUnion $ unconvert_union su+ D.SP_enum se -> SpEnum $ SpecEnum $ unconvert_alts se+ D.SP_synonym ty -> SpSynonym $ unconvert_type ty++unconvert_conversion :: D.Conversion -> (FieldName, FieldName)+unconvert_conversion c =+ ( FieldName $ T.unpack $ D._cv_injection c+ , FieldName $ T.unpack $ D._cv_projection c+ )++unconvert_specnt :: D.SpecNewtype -> SpecNewtype+unconvert_specnt sn =+ SpecNewtype+ { snType = unconvert_basic $ D._sn_type sn+ , snFilter = unconvert_filter <$> D._sn_filter sn+ }++unconvert_filter :: D.Filter -> Filter+unconvert_filter ftr =+ case ftr of+ D.FT_string (D.RegularExpression re_text) -> FtrStrg $ RegEx re_text (mkRegexWithOpts (T.unpack re_text) False True)+ D.FT_integer (D.IntRange ir_lo ir_hi) -> FtrIntg $ IntRange ir_lo ir_hi+ D.FT_utc (D.UTCRange ur_lo ur_hi) -> FtrUTC $ UTCRange ur_lo ur_hi++unconvert_fields :: [D.Field] -> [(FieldName, FieldType)]+unconvert_fields al = map f al+ where+ f fld = ( FieldName $ T.unpack $ D._fd_name fld+ , FieldType { ftType = unconvert_type $ D._fd_type fld+ , ftReadOnly = D._fd_readonly fld+ , ftDefault = unconvert_default <$> D._fd_default fld+ , ftComment = T.unpack $ D._fd_comment fld+ }+ )++unconvert_union :: [D.Field] -> [(FieldName, (APIType, MDComment))]+unconvert_union al = map f al+ where+ f fld = ( FieldName $ T.unpack $ D._fd_name fld+ , ( unconvert_type $ D._fd_type fld+ , T.unpack $ D._fd_comment fld+ ))++unconvert_alts :: [T.Text] -> [(FieldName,MDComment)]+unconvert_alts fns = map ((\x -> (x, "")) . FieldName . T.unpack) fns++unconvert_type :: D.APIType -> APIType+unconvert_type ty0 =+ case ty0 of+ D.TY_list ty -> TyList $ unconvert_type ty+ D.TY_maybe ty -> TyMaybe $ unconvert_type ty+ D.TY_ref r -> TyName $ unconvert_ref r+ D.TY_basic bt -> TyBasic $ unconvert_basic bt+ D.TY_json _ -> TyJSON++unconvert_ref :: D.TypeRef -> TypeName+unconvert_ref (D.TypeRef tn) = TypeName $ T.unpack tn++unconvert_basic :: D.BasicType -> BasicType+unconvert_basic bt =+ case bt of+ D.BT_string -> BTstring+ D.BT_binary -> BTbinary+ D.BT_boolean -> BTbool+ D.BT_integer -> BTint+ D.BT_utc -> BTutc++unconvert_default :: D.DefaultValue -> DefaultValue+unconvert_default (D.DV_list _) = DefValList+unconvert_default (D.DV_maybe _) = DefValMaybe+unconvert_default (D.DV_string s) = DefValString s+unconvert_default (D.DV_boolean b) = DefValBool b+unconvert_default (D.DV_integer i) = DefValInt i+unconvert_default (D.DV_utc u) = DefValUtc u
+ src/Data/API/API/DSL.hs view
@@ -0,0 +1,163 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -XNoCPP #-}++module Data.API.API.DSL+ ( apiAPI+ ) where++import Data.API.Parse+import Data.API.Types+++-- | API description of the api-tools API itself+apiAPI :: API+apiAPI = [api|++//+// #The api-tools API+//+// Here we make the DSP specs available in JSON so that clients+// working in non-Haskell frameworks can integrate API+// specs into their own environments.++ans :: APISpec+ // an API specification consists of a list of nodes,+ // each describing a named JSON thing which can be+ // referenced in other (object) nodes.+ = [APINode]++an :: APINode+ // Each node is named (with a name that conforms to Haskell's+ // Type identifier rules, starting with a capital letter) and some+ // comment text (like this comment). The JSON spec is all contained+ // in the {Spec}, the other fields being used behind the scenes+ // to manage the Haskell name space and migrations.+ = record+ name :: string // the name must start with a big letter+ // and conform to Haskell rules for type+ // identifiers+ comment :: string // natural language description of the node+ prefix :: string // (Haskell side only) this prefix used to+ // structure the Haskell name space+ // (which is uncomfortably flat where+ // record field names are concerned);+ // it has no effect on the JSON representation+ spec :: Spec // here we specify the JSON representation+ convert :: ? Conversion // (Haskell side only) sometimes we may+ // choose to not use the default internal+ // representation for the JSON+ // but instead supply a couple of functions+ // for injecting the default representation+ // into the actual type we will use and the+ // and project it back again; here we can check+ // some properties (which must be explained+ // in the comments) and reject a request+ // with a 400 error; has no effect on the+ // JSON representation++sp :: Spec+ // the JSON representation is specified as a simple 'newtype', a record+ // type, a union type, an enumerated type or a (mere) type synonym.+ = union+ | newtype :: SpecNewtype // here we have a basic string or number type+ | 'record' :: [Field] // an object representing a record+ | 'union' :: [Field] // an object representing a number of alternatives+ | 'enum' :: [string] // a string type which must contain a number of+ // discrete values+ | synonym :: APIType // is just an alias for another type++sn :: SpecNewtype+ // 'newtype' specs are a basic type and an optional filter specification+ = record+ type :: BasicType+ filter :: ? Filter++ft :: Filter+ = union+ | 'string' :: RegularExpression+ | 'integer' :: IntRange+ | 'utc' :: UTCRange++re :: RegularExpression+ // regular expressions are represented by simple strings+ = basic string++ir :: IntRange+ // integer ranges are specified with their bounds and may open at+ // the bottom and top+ = record+ lo :: ? integer+ hi :: ? integer++ur :: UTCRange+ // UTC ranges are specified with their bounds and may open at+ // the bottom and top+ = record+ lo :: ? utc+ hi :: ? utc++cv :: Conversion+ // Conversions are just used on the Haskell side to map the concrete JSON+ // representation into an internal type and back again+ = record+ injection :: string // the injection function for injecting+ // representations into the internal+ // representation; may return a failure+ // indicating that some API precondition+ // was not met+ projection:: string // the projection function converts the+ // internal type back into the JSON+ // representation for communication+ // back to the client++fd :: Field+ // a field represent both a field in a record object and an alternative in+ // a union object (in which exactly one of the 'fields' is ever present in+ // the object)+ = record+ name :: string // the name of the method+ type :: APIType // the JSON type of the field+ readonly :: boolean // read-only status+ default :: ? DefaultValue // the default value of the field+ comment :: string // a comment describing the field (like+ // this one)++ty :: APIType+ // this is used to represent JSON types in fields (or synonyms) and is one+ // one of the following:+ = union+ | list :: APIType // a JSON list of the given type+ | maybe :: APIType // either the given type or the null value+ | ref :: TypeRef // a named type (node) with possible example+ | 'basic':: BasicType // a basic JSON type+ | 'json' :: integer // a generic JSON value++tr :: TypeRef+ // reference to a type name+ = basic string++bt :: BasicType+ // finally we get down to the basic JSON types ('binary' is a string+ // in which the byte string has been encoded with base-64, safe for+ // embedding in a UTF-8-encoded JSON string+ = enum+ | 'string'+ | 'binary'+ | 'boolean'+ | 'integer'+ | 'utc'++dv :: DefaultValue+ // a default value+ = union+ | 'list' :: integer+ | 'maybe' :: integer+ | 'string' :: string+ | 'boolean' :: boolean+ | 'integer' :: integer+ | 'utc' :: utc+|]++{-+-}
+ src/Data/API/API/Gen.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | This module contains datatypes generated from the DSL description+-- of the api-tools API; they thus correspond to the types in+-- "Data.API.Types".+module Data.API.API.Gen where++import Data.API.API.DSL+import Data.API.Tools++import Language.Haskell.TH++$(generate apiAPI)++$(generateAPITools apiAPI+ [ enumTool+ , jsonTool+ , quickCheckTool+ , lensTool+ , safeCopyTool+ , exampleTool+ , samplesTool (mkName "apiAPISamples")+ , jsonTestsTool (mkName "apiAPISimpleTests")+ ])
+ src/Data/API/Changes.hs view
@@ -0,0 +1,1262 @@+{-# OPTIONS_GHC -fno-warn-deprecations #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module deals with validating API changelogs and migrating+-- JSON data between different versions of a schema.+module Data.API.Changes+ ( migrateDataDump++ -- * Validating changelogs+ , validateChanges+ , dataMatchesAPI+ , DataChecks(..)++ -- * Changelog representation+ , APIChangelog(..)+ , APIWithChangelog+ , APIChange(..)+ , VersionExtra(..)+ , showVersionExtra+ , changelogStartVersion+ , changelogVersion++ -- * Custom migrations+ , CustomMigrations(..)+ , generateMigrationKinds+ , MigrationTag++ -- * API normal forms+ , NormAPI+ , NormTypeDecl(..)+ , NormRecordType+ , NormUnionType+ , NormEnumType+ , apiNormalForm+ , declNF++ -- * Migration errors+ , MigrateFailure(..)+ , MigrateWarning+ , ValidateFailure(..)+ , ValidateWarning+ , ApplyFailure(..)+ , TypeKind(..)+ , MergeResult(..)+ , ValueError(..)+ , prettyMigrateFailure+ , prettyValidateFailure+ , prettyValueError+ , prettyValueErrorPosition+ ) where++import Data.API.JSON+import Data.API.PP+import Data.API.Types+import Data.API.Utils++import Control.Applicative+import Control.Monad+import qualified Data.Aeson as JS+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Base64 as B64+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.HashMap.Strict as HMap+import qualified Data.Vector as V+import qualified Data.Text as T+import Data.Version+import Data.Time+import Data.List+import Language.Haskell.TH+import Safe+++-------------------------+-- Top level: do it all+--++-- | Migrate a dataset from one version of an API schema to another.+-- The data must be described by a named type, the name of which is+-- assumed not to change.+--+-- The @db@, @rec@ and @fld@ types must be enumerations of all the+-- custom migration tags in the changelog, as generated by+-- 'generateMigrationKind'.++migrateDataDump :: (Read db, Read rec, Read fld)+ => (API, Version) -- ^ Starting schema and version+ -> (API, VersionExtra) -- ^ Ending schema and version+ -> APIChangelog -- ^ Log of changes, containing both versions+ -> CustomMigrations db rec fld -- ^ Custom migration functions+ -> TypeName -- ^ Name of the dataset's type+ -> DataChecks -- ^ How thoroughly to validate changes+ -> JS.Value -- ^ Dataset to be migrated+ -> Either MigrateFailure (JS.Value, [MigrateWarning])+migrateDataDump startApi endApi changelog custom root chks db = do+ let custom' = readCustomMigrations custom+ (changes, warnings) <- validateChanges' startApi endApi changelog custom' root chks+ ?!? ValidateFailure+ db' <- applyChangesToDatabase root custom' db changes ?!? uncurry ValueError+ return (db', warnings)++data MigrateFailure+ = ValidateFailure ValidateFailure+ | ValueError ValueError Position+ deriving (Eq, Show)++type MigrateWarning = ValidateWarning++------------------+-- The key types+--++type APIWithChangelog = (API, APIChangelog)++-- | An API changelog, consisting of a list of versions with the+-- changes from one version to the next. The versions must be in+-- descending order (according to the 'Ord' 'Version' instance).+data APIChangelog =+ -- | The changes from the previous version up to this version.+ ChangesUpTo VersionExtra [APIChange] APIChangelog+ -- | The initial version+ | ChangesStart Version+ deriving (Eq, Show)++-- | A single change within a changelog+data APIChange+ = ChAddType TypeName NormTypeDecl+ | ChDeleteType TypeName+ | ChRenameType TypeName TypeName++ -- Specific changes for record types+ | ChAddField TypeName FieldName APIType (Maybe DefaultValue)+ | ChDeleteField TypeName FieldName+ | ChRenameField TypeName FieldName FieldName+ | ChChangeField TypeName FieldName APIType MigrationTag++ -- Changes for union types+ | ChAddUnionAlt TypeName FieldName APIType+ | ChDeleteUnionAlt TypeName FieldName+ | ChRenameUnionAlt TypeName FieldName FieldName++ -- Changes for enum types+ | ChAddEnumVal TypeName FieldName+ | ChDeleteEnumVal TypeName FieldName+ | ChRenameEnumVal TypeName FieldName FieldName++ -- Custom value (not type) changes+ | ChCustomRecord TypeName MigrationTag+ | ChCustomAll MigrationTag+ deriving (Eq, Show)++-- | Within the changelog, custom migrations are represented as+-- strings, so we have less type-safety.+type MigrationTag = String++-- | Custom migrations used in the changelog must be implemented in+-- Haskell, and supplied in this record. There are three kinds:+--+-- * Whole-database migrations, which may arbitrarily change the API+-- schema and the data to match;+--+-- * Record migrations, which may change the schema of a single+-- record; and+--+-- * Single field migrations, which may change only the type of the+-- field (with the new type specified in the changelog).+--+-- For database and record migrations, if the schema is unchanged, the+-- corresponding function should return 'Nothing'.+--+-- The @db@, @rec@ and @fld@ parameters should be instantiated with+-- the enumeration types generated by 'generateMigrationKinds', which+-- correspond to the exact set of custom migration tags used in the+-- changelog.+data CustomMigrations db rec fld = CustomMigrations+ { databaseMigration :: db -> JS.Object -> Either ValueError JS.Object+ , databaseMigrationSchema :: db -> NormAPI -> Maybe NormAPI+ , recordMigration :: rec -> JS.Object -> Either ValueError JS.Object+ , recordMigrationSchema :: rec -> NormRecordType -> Maybe NormRecordType+ , fieldMigration :: fld -> JS.Value -> Either ValueError JS.Value }++type CustomMigrationsTagged = CustomMigrations MigrationTag MigrationTag MigrationTag++readCustomMigrations :: (Read db, Read rec, Read fld)+ => CustomMigrations db rec fld -> CustomMigrationsTagged+readCustomMigrations (CustomMigrations db dbs r rs f) =+ CustomMigrations (db . read) (dbs . read) (r . read) (rs . read) (f . read)+++-- | When to validate the data against the schema (each level implies+-- the preceding levels):+data DataChecks = NoChecks -- ^ Not at all+ | CheckStartAndEnd -- ^ At start and end of the migration+ | CheckCustom -- ^ After custom migrations+ | CheckAll -- ^ After every change+ deriving (Eq, Ord)++-- | Whether to validate the dataset after this change+validateAfter :: DataChecks -> APIChange -> Bool+validateAfter chks (ChChangeField{}) = chks >= CheckCustom+validateAfter chks (ChCustomRecord{}) = chks >= CheckCustom+validateAfter chks (ChCustomAll{}) = chks >= CheckCustom+validateAfter chks _ = chks >= CheckAll+++--------------------+-- Changelog utils+--++-- | Represents either a released version (with a version number) or+-- the version under development, which is newer than any release+data VersionExtra = Release Version+ | DevVersion+ deriving (Eq, Ord, Show)++showVersionExtra :: VersionExtra -> String+showVersionExtra (Release v) = showVersion v+showVersionExtra DevVersion = "development"++instance PP VersionExtra where+ pp = showVersionExtra+++-- | The earliest version in the changelog+changelogStartVersion :: APIChangelog -> Version+changelogStartVersion (ChangesStart v) = v+changelogStartVersion (ChangesUpTo _ _ clog) = changelogStartVersion clog++-- | The latest version in the changelog+changelogVersion :: APIChangelog -> VersionExtra+changelogVersion (ChangesStart v) = Release v+changelogVersion (ChangesUpTo v _ _) = v++-- | Changelog in order starting from oldest version up to newest.+-- Entries are @(from, to, changes-oldest-first)@.+viewChangelogReverse :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]+viewChangelogReverse clog =+ reverse [ (v,v',reverse cs) | (v',v,cs) <- viewChangelog clog ]++-- | Changelog in order as written, with latest version at the beginning, going+-- back to older versions. Entries are @(to, from, changes-latest-first)@.+viewChangelog :: APIChangelog -> [(VersionExtra, VersionExtra, [APIChange])]+viewChangelog (ChangesStart _) = []+viewChangelog (ChangesUpTo v' cs older) = (v', v, cs) : viewChangelog older+ where v = changelogVersion older++-- | Is the changelog in the correct order? If not, return a pair of+-- out-of-order versions.+isChangelogOrdered :: APIChangelog -> Either (VersionExtra, VersionExtra) ()+isChangelogOrdered changelog =+ case find (\ (v', v, _) -> v' <= v) (viewChangelog changelog) of+ Nothing -> return ()+ Just (v', v, _) -> Left (v', v)+++-- | Sets of custom migration tags in the changelog for+-- whole-database, single-record and single-field migrations+changelogTags :: APIChangelog -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)+changelogTags (ChangesStart _) = (Set.empty, Set.empty, Set.empty)+changelogTags (ChangesUpTo _ cs older) =+ unions3 (map changeTags cs) `union3` changelogTags older+ where+ union3 (a, b, c) (x, y, z) = (a `Set.union` x, b `Set.union` y, c `Set.union` z)+ unions3 xyzs = (Set.unions xs, Set.unions ys, Set.unions zs)+ where (xs, ys, zs) = unzip3 xyzs++-- | Sets of custom migration tags in a single change+changeTags :: APIChange -> (Set MigrationTag, Set MigrationTag, Set MigrationTag)+changeTags (ChChangeField _ _ _ t) = (Set.empty, Set.empty, Set.singleton t)+changeTags (ChCustomRecord _ t) = (Set.empty, Set.singleton t, Set.empty)+changeTags (ChCustomAll t) = (Set.singleton t, Set.empty, Set.empty)+changeTags _ = (Set.empty, Set.empty, Set.empty)+++------------------------------------------+-- Comparing APIs: canonical/normal form+--++-- | The API type has too much extra info for us to be able to simply compare+-- them with @(==)@. Our strategy is to strip out ancillary information and+-- normalise into a canonical form, and then we can use a simple @(==)@ compare.+--+-- Our normalised API discards most of the details of each type, keeping+-- just essential information about each type. We discard order of types and+-- fields, so we can use just associative maps.+--+type NormAPI = Map TypeName NormTypeDecl++-- | The normal or canonical form for a type declaration, an 'APINode'.+-- Equality of the normal form indicates equivalence of APIs.+--+-- We track all types.+--+data NormTypeDecl+ = NRecordType NormRecordType+ | NUnionType NormUnionType+ | NEnumType NormEnumType+ | NTypeSynonym APIType+ | NNewtype BasicType+ deriving (Eq, Show)++-- | The canonical form of a record type is a map from fields to+-- values; similarly a union is a map from fields to alternatives and+-- an enum is a set of values.+type NormRecordType = Map FieldName APIType+type NormUnionType = Map FieldName APIType+type NormEnumType = Set FieldName+++-- | Compute the normal form of an API, discarding extraneous information.+apiNormalForm :: API -> NormAPI+apiNormalForm api =+ Map.fromList+ [ (name, declNF spec)+ | ThNode (APINode {anName = name, anSpec = spec}) <- api ]++-- | Compute the normal form of a single type declaration.+declNF :: Spec -> NormTypeDecl+declNF (SpRecord (SpecRecord fields)) = NRecordType $ Map.fromList+ [ (fname, ftType ftype)+ | (fname, ftype) <- fields ]+declNF (SpUnion (SpecUnion alts)) = NUnionType $ Map.fromList+ [ (fname, ftype)+ | (fname, (ftype, _)) <- alts ]+declNF (SpEnum (SpecEnum elems)) = NEnumType $ Set.fromList+ [ fname | (fname, _) <- elems ]+declNF (SpSynonym t) = NTypeSynonym t+declNF (SpNewtype (SpecNewtype bt _)) = NNewtype bt+++-------------------------+-- Type decl/expr utils+--++typeDelcsFreeVars :: NormAPI -> Set TypeName+typeDelcsFreeVars = Set.unions . map typeDelcFreeVars . Map.elems++typeDelcFreeVars :: NormTypeDecl -> Set TypeName+typeDelcFreeVars (NRecordType fields) = Set.unions . map typeFreeVars+ . Map.elems $ fields+typeDelcFreeVars (NUnionType alts) = Set.unions . map typeFreeVars+ . Map.elems $ alts+typeDelcFreeVars (NEnumType _) = Set.empty+typeDelcFreeVars (NTypeSynonym t) = typeFreeVars t+typeDelcFreeVars (NNewtype _) = Set.empty++typeFreeVars :: APIType -> Set TypeName+typeFreeVars (TyList t) = typeFreeVars t+typeFreeVars (TyMaybe t) = typeFreeVars t+typeFreeVars (TyName n) = Set.singleton n+typeFreeVars (TyBasic _) = Set.empty+typeFreeVars TyJSON = Set.empty++mapTypeDeclFreeVars :: (TypeName -> APIType) -> NormTypeDecl -> NormTypeDecl+mapTypeDeclFreeVars f (NRecordType fields) = NRecordType (Map.map (mapTypeFreeVars f) fields)+mapTypeDeclFreeVars f (NUnionType alts) = NUnionType (Map.map (mapTypeFreeVars f) alts)+mapTypeDeclFreeVars _ d@(NEnumType _) = d+mapTypeDeclFreeVars f (NTypeSynonym t) = NTypeSynonym (mapTypeFreeVars f t)+mapTypeDeclFreeVars _ d@(NNewtype _) = d++mapTypeFreeVars :: (TypeName -> APIType) -> APIType -> APIType+mapTypeFreeVars f (TyList t) = TyList (mapTypeFreeVars f t)+mapTypeFreeVars f (TyMaybe t) = TyMaybe (mapTypeFreeVars f t)+mapTypeFreeVars f (TyName n) = f n+mapTypeFreeVars _ t@(TyBasic _) = t+mapTypeFreeVars _ t@TyJSON = t+++typeDeclaredInApi :: TypeName -> NormAPI -> Bool+typeDeclaredInApi tname api = Map.member tname api++-- | Check if a type is used anywhere in the API+typeUsedInApi :: TypeName -> NormAPI -> Bool+typeUsedInApi tname api = tname `Set.member` typeDelcsFreeVars api++-- | Check if a type is used anywhere in the database (possibly in a+-- transitive dependency of the root).+typeUsedInApiTable :: TypeName -> TypeName -> NormAPI -> Bool+typeUsedInApiTable root tname api =+ tname == root || tname `Set.member` transitiveDeps api (Set.singleton root)++-- | Compute the transitive dependencies of a set of types+transitiveDeps :: NormAPI -> Set TypeName -> Set TypeName+transitiveDeps api = transitiveClosure $ \ s ->+ typeDelcsFreeVars $+ Map.filterWithKey (\ x _ -> x `Set.member` s) api++-- | Compute the set of types that depend (transitively) on the given types+transitiveSped :: NormAPI -> Set TypeName -> Set TypeName+transitiveSped api = transitiveClosure $ \ s ->+ Map.keysSet $+ Map.filter (intersects s . typeDelcFreeVars) api+ where+ intersects s1 s2 = not $ Set.null $ s1 `Set.intersection` s2++-- | Compute the transitive closure of a relation. Relations are+-- represented as functions that takes a set of elements to the set of+-- related elements.+transitiveClosure :: Ord a => (Set a -> Set a) -> Set a -> Set a+transitiveClosure rel x = findUsed x0 x0+ where+ x0 = rel x++ findUsed seen old+ | Set.null new = seen+ | otherwise = findUsed (seen `Set.union` new) new+ where+ new = rel old `Set.difference` seen++renameTypeUses :: TypeName -> TypeName -> NormAPI -> NormAPI+renameTypeUses tname tname' = Map.map (mapTypeDeclFreeVars rename)+ where+ rename tn | tn == tname = TyName tname'+ | otherwise = TyName tn++typeIsValid :: APIType -> NormAPI -> Either (Set TypeName) ()+typeIsValid t api+ | typeVars `Set.isSubsetOf` declaredTypes = return ()+ | otherwise = Left (typeVars Set.\\ declaredTypes)+ where+ typeVars = typeFreeVars t+ declaredTypes = Map.keysSet api++declIsValid :: NormTypeDecl -> NormAPI -> Either (Set TypeName) ()+declIsValid decl api+ | declVars `Set.isSubsetOf` declaredTypes = return ()+ | otherwise = Left (declVars Set.\\ declaredTypes)+ where+ declVars = typeDelcFreeVars decl+ declaredTypes = Map.keysSet api++apiInvariant :: NormAPI -> Either (Set TypeName) ()+apiInvariant api+ | usedTypes `Set.isSubsetOf` declaredTypes = return ()+ | otherwise = Left (usedTypes Set.\\ declaredTypes)+ where+ usedTypes = typeDelcsFreeVars api+ declaredTypes = Map.keysSet api+++--------------------------------+-- Representing update positions+--++-- | Represents the positions in a declaration to apply an update+data UpdateDeclPos+ = UpdateHere (Maybe UpdateDeclPos)+ | UpdateRecord (Map FieldName (Maybe UpdateTypePos))+ | UpdateUnion (Map FieldName (Maybe UpdateTypePos))+ | UpdateType UpdateTypePos+ deriving (Eq, Show)++-- | Represents the positions in a type to apply an update+data UpdateTypePos+ = UpdateList UpdateTypePos+ | UpdateMaybe UpdateTypePos+ | UpdateNamed TypeName+ deriving (Eq, Show)++data APITableChange+ -- | The pair of an APIChange and the positions in which to apply it+ = APIChange APIChange (Map TypeName UpdateDeclPos)+ -- | Request to validate the dataset against the given API+ | ValidateData NormAPI+ deriving (Eq, Show)++-- | Given a type to be modified, find the positions in which each+-- type in the API must be updated+findUpdatePos :: TypeName -> NormAPI -> Map TypeName UpdateDeclPos+findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $+ Map.fromSet findDecl deps+ where+ -- The set of types that depend on the type being updated+ deps :: Set TypeName+ deps = transitiveSped api (Set.singleton tname)++ findDecl :: TypeName -> UpdateDeclPos+ findDecl tname' = findDecl' $+ fromMaybe (error "findUpdatePos: missing type") $+ Map.lookup tname' api++ findDecl' :: NormTypeDecl -> UpdateDeclPos+ findDecl' (NRecordType flds) = UpdateRecord $ fmap findType flds+ findDecl' (NUnionType alts) = UpdateUnion $ fmap findType alts+ findDecl' (NEnumType _) = error "findDecl': unexpected enum"+ findDecl' (NTypeSynonym ty) = UpdateType $ fromMaybe (error "findDecl': missing") $+ findType ty+ findDecl' (NNewtype _) = error "findDecl': unexpected newtype"++ findType :: APIType -> Maybe UpdateTypePos+ findType (TyList ty) = UpdateList <$> findType ty+ findType (TyMaybe ty) = UpdateMaybe <$> findType ty+ findType (TyName tname')+ | tname' == tname || tname' `Set.member` deps = Just $ UpdateNamed tname'+ | otherwise = Nothing+ findType (TyBasic _) = Nothing+ findType TyJSON = Nothing+++---------------------------+-- Validating API changes+--++-- | Errors that may be discovered when validating a changelog+data ValidateFailure+ -- | the changelog must be in descending order of versions+ = ChangelogOutOfOrder { vfLaterVersion :: VersionExtra+ , vfEarlierVersion :: VersionExtra }+ -- | forbid migrating from one version to an earlier version+ | CannotDowngrade { vfFromVersion :: VersionExtra+ , vfToVersion :: VersionExtra }+ -- | an API uses types that are not declared+ | ApiInvalid { vfInvalidVersion :: VersionExtra+ , vfMissingDeclarations :: Set TypeName }+ -- | changelog entry does not apply+ | ChangelogEntryInvalid { vfSuccessfullyApplied :: [APITableChange]+ , vfFailedToApply :: APIChange+ , vfApplyFailure :: ApplyFailure }+ -- | changelog is incomplete+ -- (ie all entries apply ok but result isn't the target api)+ | ChangelogIncomplete { vfChangelogVersion :: VersionExtra+ , vfTargetVersion :: VersionExtra+ , vfDifferences :: Map TypeName (MergeResult NormTypeDecl NormTypeDecl) }+ deriving (Eq, Show)++data ValidateWarning = ValidateWarning -- add warnings about bits we cannot check (opaque custom)+ deriving Show++-- | Errors that may occur applying a single API change+data ApplyFailure+ = TypeExists { afExistingType :: TypeName } -- ^ for adding or renaming type+ | TypeDoesNotExist { afMissingType :: TypeName } -- ^ for deleting or renaming a type+ | TypeWrongKind { afTypeName :: TypeName+ , afExpectedKind :: TypeKind } -- ^ e.g. it's not a record type+ | TypeInUse { afTypeName :: TypeName } -- ^ cannot delete/modify types that are still used+ | TypeMalformed { afType :: APIType+ , afMissingTypes :: Set TypeName } -- ^ type refers to a non-existent type+ | DeclMalformed { afTypeName :: TypeName+ , afDecl :: NormTypeDecl+ , afMissingTypes :: Set TypeName } -- ^ decl refers to a non-existent type+ | FieldExists { afTypeName :: TypeName+ , afTypeKind :: TypeKind+ , afExistingField :: FieldName } -- ^ for adding or renaming a field+ | FieldDoesNotExist { afTypeName :: TypeName+ , afTypeKind :: TypeKind+ , afMissingField :: FieldName } -- ^ for deleting or renaming a field+ | FieldBadDefaultValue { afTypeName :: TypeName+ , afFieldName :: FieldName+ , afFieldType :: APIType+ , afBadDefault :: DefaultValue } -- ^ for adding a field, must be a default+ -- value compatible with the type+ | DefaultMissing { afTypeName :: TypeName+ , afFieldName :: FieldName } -- ^ for adding a field to a table+ | TableChangeError { afCustomMessage :: String } -- ^ custom error in tableChange+ deriving (Eq, Show)++data TypeKind = TKRecord | TKUnion | TKEnum+ deriving (Eq, Show)+++-- | Check that a changelog adequately describes how to migrate from+-- one version to another.+validateChanges :: (Read db, Read rec, Read fld)+ => (API, Version) -- ^ Starting schema and version+ -> (API, VersionExtra) -- ^ Ending schema and version+ -> APIChangelog -- ^ Changelog to be validated+ -> CustomMigrations db rec fld -- ^ Custom migration functions+ -> TypeName -- ^ Name of the dataset's type+ -> DataChecks -- ^ How thoroughly to validate changes+ -> Either ValidateFailure [ValidateWarning]+validateChanges (api,ver) (api',ver') clog custom root chks = snd <$>+ validateChanges' (api,ver) (api',ver') clog (readCustomMigrations custom) root chks++-- | Internal version of 'validateChanges', which works on unsafe+-- migration tags and returns the list of 'APITableChange's to apply+-- to the dataset.+validateChanges' :: (API, Version) -- ^ Starting schema and version+ -> (API, VersionExtra) -- ^ Ending schema and version+ -> APIChangelog -- ^ Changelog to be validated+ -> CustomMigrationsTagged -- ^ Custom migration functions+ -> TypeName -- ^ Name of the dataset's type+ -> DataChecks -- ^ How thoroughly to validate changes+ -> Either ValidateFailure ([APITableChange], [ValidateWarning])+validateChanges' (api,ver) (api',ver') clog custom root chks = do+ -- select changes by version from log+ (changes, verEnd) <- selectChanges clog (Release ver) ver'+ -- take norm of start and end api,+ let apiStart = apiNormalForm api+ apiTarget = apiNormalForm api'+ -- check start and end APIs are well formed.+ apiInvariant apiStart ?!? ApiInvalid (Release ver)+ apiInvariant apiTarget ?!? ApiInvalid ver'+ -- check expected end api+ (apiEnd, changes') <- applyAPIChangesToAPI root custom chks changes apiStart+ -- check expected end api+ guard (apiEnd == apiTarget) ?! ChangelogIncomplete verEnd ver' (diffMaps apiEnd apiTarget)+ return (changes', [])++selectChanges :: APIChangelog -> VersionExtra -> VersionExtra+ -> Either ValidateFailure ([APIChange], VersionExtra)+selectChanges clog ver ver'+ | ver' == ver = return ([], ver')+ | ver' > ver = do+ isChangelogOrdered clog ?!? uncurry ChangelogOutOfOrder+ let withinRange = takeWhile (\ (_, v, _) -> v <= ver') $+ dropWhile (\ (_, v, _) -> v <= ver) $+ viewChangelogReverse clog+ endVer = case lastMay withinRange of+ Nothing -> ver+ Just (_, v, _) -> v+ return ([ c | (_,_, cs) <- withinRange, c <- cs ], endVer)++ | otherwise = Left (CannotDowngrade ver ver')++-- | Apply a list of changes to an API, returning the updated API and+-- a list of the changes with appropriate TableChanges interspersed.+-- On failure, return the list of successfully applied changes, the+-- change that failed and the reason for the failure.+applyAPIChangesToAPI :: TypeName -> CustomMigrationsTagged -> DataChecks+ -> [APIChange] -> NormAPI+ -> Either ValidateFailure (NormAPI, [APITableChange])+applyAPIChangesToAPI root custom chks changes api = do+ (api', changes') <- foldM (doChangeAPI root custom chks) (api, []) changes+ let changes'' | chks >= CheckStartAndEnd = addV api $ reverse $ addV api' changes'+ | otherwise = reverse changes'+ return (api', changes'')+ where+ addV _ cs@(ValidateData _ : _) = cs+ addV a cs = ValidateData a : cs++-- | Apply the API change+doChangeAPI :: TypeName -> CustomMigrationsTagged -> DataChecks+ -> (NormAPI, [APITableChange]) -> APIChange+ -> Either ValidateFailure (NormAPI, [APITableChange])+doChangeAPI root custom chks (api, changes) change = do+ (api', pos) <- applyAPIChangeToAPI root custom change api+ ?!? ChangelogEntryInvalid changes change+ let changes' = APIChange change pos : changes+ changes'' | validateAfter chks change = ValidateData api' : changes'+ | otherwise = changes'+ return (api', changes'')++-- Checks and and performs an API change. If it works then we get back the new+-- overall api. This is used for two purposes, (1) validating that we can apply+-- each change in that context, and that we end up with the API we expect+-- and (2) getting the intermediate APIs during data migration, because we need+-- the schema of the intermediate data as part of applying the migration.+applyAPIChangeToAPI :: TypeName -> CustomMigrationsTagged -> APIChange -> NormAPI+ -> Either ApplyFailure (NormAPI, Map TypeName UpdateDeclPos)++applyAPIChangeToAPI _ _ (ChAddType tname tdecl) api = do+ -- to add a new type, that type must not yet exist+ guard (not (tname `typeDeclaredInApi` api)) ?! TypeExists tname+ declIsValid tdecl api ?!? DeclMalformed tname tdecl+ return (Map.insert tname tdecl api, Map.empty)++applyAPIChangeToAPI _ _ (ChDeleteType tname) api = do+ -- to delete a type, that type must exist+ guard (tname `typeDeclaredInApi` api) ?! TypeDoesNotExist tname+ -- it must also not be used anywhere else in the API+ guard (not (tname `typeUsedInApi` api)) ?! TypeInUse tname+ return (Map.delete tname api, Map.empty)++applyAPIChangeToAPI _ _ (ChRenameType tname tname') api = do+ -- to rename a type, the original type name must exist+ -- and the new one must not yet exist+ tinfo <- lookupType tname api+ guard (not (tname' `typeDeclaredInApi` api)) ?! TypeExists tname'+ return ( (renameTypeUses tname tname'+ . Map.insert tname' tinfo . Map.delete tname) api+ , Map.empty )++applyAPIChangeToAPI _ custom (ChCustomRecord tname tag) api = do+ -- to make some change to values of a type, the type name must exist+ tinfo <- lookupType tname api+ recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+ let api' = case recordMigrationSchema custom tag recinfo of+ Just recinfo' -> Map.insert tname (NRecordType recinfo') api+ Nothing -> api+ return (api', findUpdatePos tname api)++applyAPIChangeToAPI root _ (ChAddField tname fname ftype mb_defval) api = do+ tinfo <- lookupType tname api+ recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+ guard (not (Map.member fname recinfo)) ?! FieldExists tname TKRecord fname+ typeIsValid ftype api ?!? TypeMalformed ftype+ case mb_defval <|> defaultValueForType ftype of+ Just defval -> guard (compatibleDefaultValue api ftype defval)+ ?! FieldBadDefaultValue tname fname ftype defval+ Nothing -> guard (not (typeUsedInApiTable root tname api))+ ?! DefaultMissing tname fname+ let tinfo' = NRecordType (Map.insert fname ftype recinfo)+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI _ _ (ChDeleteField tname fname) api = do+ tinfo <- lookupType tname api+ recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+ guard (Map.member fname recinfo) ?! FieldDoesNotExist tname TKRecord fname+ let tinfo' = NRecordType (Map.delete fname recinfo)+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI _ _ (ChRenameField tname fname fname') api = do+ tinfo <- lookupType tname api+ recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+ ftype <- Map.lookup fname recinfo ?! FieldDoesNotExist tname TKRecord fname+ guard (not (Map.member fname' recinfo)) ?! FieldExists tname TKRecord fname'+ let tinfo' = (NRecordType . Map.insert fname' ftype+ . Map.delete fname) recinfo+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI _ _ (ChChangeField tname fname ftype _) api = do+ tinfo <- lookupType tname api+ recinfo <- expectRecordType tinfo ?! TypeWrongKind tname TKRecord+ guard (Map.member fname recinfo) ?! FieldDoesNotExist tname TKRecord fname+ let tinfo' = (NRecordType . Map.insert fname ftype) recinfo+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI _ _ (ChAddUnionAlt tname fname ftype) api = do+ tinfo <- lookupType tname api+ unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion+ guard (not (Map.member fname unioninfo)) ?! FieldExists tname TKUnion fname+ typeIsValid ftype api ?!? TypeMalformed ftype+ let tinfo' = NUnionType (Map.insert fname ftype unioninfo)+ return (Map.insert tname tinfo' api, Map.empty)++applyAPIChangeToAPI root _ (ChDeleteUnionAlt tname fname) api = do+ tinfo <- lookupType tname api+ unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion+ guard (not (typeUsedInApiTable root tname api)) ?! TypeInUse tname+ guard (Map.member fname unioninfo) ?! FieldDoesNotExist tname TKUnion fname+ let tinfo' = NUnionType (Map.delete fname unioninfo)+ return (Map.insert tname tinfo' api, Map.empty)++applyAPIChangeToAPI _ _ (ChRenameUnionAlt tname fname fname') api = do+ tinfo <- lookupType tname api+ unioninfo <- expectUnionType tinfo ?! TypeWrongKind tname TKUnion+ ftype <- Map.lookup fname unioninfo ?! FieldDoesNotExist tname TKUnion fname+ guard (not (Map.member fname' unioninfo)) ?! FieldExists tname TKUnion fname'+ let tinfo' = (NUnionType . Map.insert fname' ftype+ . Map.delete fname) unioninfo+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI _ _ (ChAddEnumVal tname fname) api = do+ tinfo <- lookupType tname api+ enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum+ guard (not (Set.member fname enuminfo)) ?! FieldExists tname TKEnum fname+ let tinfo' = NEnumType (Set.insert fname enuminfo)+ return (Map.insert tname tinfo' api, Map.empty)++applyAPIChangeToAPI root _ (ChDeleteEnumVal tname fname) api = do+ tinfo <- lookupType tname api+ enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum+ guard (not (typeUsedInApiTable root tname api)) ?! TypeInUse tname+ guard (Set.member fname enuminfo) ?! FieldDoesNotExist tname TKEnum fname+ let tinfo' = NEnumType (Set.delete fname enuminfo)+ return (Map.insert tname tinfo' api, Map.empty)++applyAPIChangeToAPI _ _ (ChRenameEnumVal tname fname fname') api = do+ tinfo <- lookupType tname api+ enuminfo <- expectEnumType tinfo ?! TypeWrongKind tname TKEnum+ guard (Set.member fname enuminfo) ?! FieldDoesNotExist tname TKEnum fname+ guard (not (Set.member fname' enuminfo)) ?! FieldExists tname TKEnum fname'+ let tinfo' = (NEnumType . Set.insert fname'+ . Set.delete fname) enuminfo+ return (Map.insert tname tinfo' api, findUpdatePos tname api)++applyAPIChangeToAPI root custom (ChCustomAll tag) api =+ return ( fromMaybe api (databaseMigrationSchema custom tag api)+ , Map.singleton root (UpdateHere Nothing))+++lookupType :: TypeName -> NormAPI -> Either ApplyFailure NormTypeDecl+lookupType tname api = Map.lookup tname api ?! TypeDoesNotExist tname++expectRecordType :: NormTypeDecl -> Maybe (Map FieldName APIType)+expectRecordType (NRecordType rinfo) = Just rinfo+expectRecordType _ = Nothing++expectUnionType :: NormTypeDecl -> Maybe (Map FieldName APIType)+expectUnionType (NUnionType rinfo) = Just rinfo+expectUnionType _ = Nothing++expectEnumType :: NormTypeDecl -> Maybe (Set FieldName)+expectEnumType (NEnumType rinfo) = Just rinfo+expectEnumType _ = Nothing+++-----------------------------------+-- Performing data transformation+--++-- | This is the low level one that just does the changes.+--+-- We assume the changes have already been validated, and that the data+-- matches the API.+--+applyChangesToDatabase :: TypeName -> CustomMigrationsTagged+ -> JS.Value -> [APITableChange]+ -> Either (ValueError, Position) JS.Value+applyChangesToDatabase root custom = foldM (applyChangeToDatabase root custom)+ -- just apply each of the individual changes in sequence to the whole dataset++applyChangeToDatabase :: TypeName -> CustomMigrationsTagged+ -> JS.Value -> APITableChange+ -> Either (ValueError, Position) JS.Value+applyChangeToDatabase root custom v (APIChange c upds) =+ updateTypeAt upds (applyChangeToData c custom) (UpdateNamed root) v []+applyChangeToDatabase root _ v (ValidateData api) = do+ dataMatchesNormAPI root api v+ return v+++-- | Apply an update at the given position in a declaration's value+updateDeclAt :: Map TypeName UpdateDeclPos+ -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> UpdateDeclPos+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+updateDeclAt _ alter (UpdateHere Nothing) v p = alter v p+updateDeclAt upds alter (UpdateHere (Just upd)) v p = flip alter p =<< updateDeclAt upds alter upd v p+updateDeclAt upds alter (UpdateRecord upd_flds) v p = withObjectMatchingFields upd_flds+ (maybe (pure . pure) (updateTypeAt upds alter)) v p+updateDeclAt upds alter (UpdateUnion upd_alts) v p = withObjectMatchingUnion upd_alts+ (maybe (pure . pure) (updateTypeAt upds alter)) v p+updateDeclAt upds alter (UpdateType upd) v p = updateTypeAt upds alter upd v p++-- | Apply an upate at the given position in a type's value+updateTypeAt :: Map TypeName UpdateDeclPos+ -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> UpdateTypePos+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+updateTypeAt upds alter (UpdateList upd) v p = withArrayElems (updateTypeAt upds alter upd) v p+updateTypeAt upds alter (UpdateMaybe upd) v p = withMaybe (updateTypeAt upds alter upd) v p+updateTypeAt upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of+ Just upd -> updateDeclAt upds alter upd v p+ Nothing -> pure v+++-- | This actually applies the change to the data value, assuming it+-- is already in the correct place+applyChangeToData :: APIChange -> CustomMigrationsTagged+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value++applyChangeToData (ChAddField tname fname ftype mb_defval) _ =+ case mb_defval <|> defaultValueForType ftype of+ Just defval -> let newFieldValue = defaultValueAsJsValue defval+ in withObject (\ v _ -> pure $ HMap.insert (fieldKey fname) newFieldValue v)+ Nothing -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p)++applyChangeToData (ChDeleteField _ fname) _ =+ withObject (\ v _ -> pure $ HMap.delete (fieldKey fname) v)++applyChangeToData (ChRenameField _ fname fname') _ =+ withObject $ \rec p -> case HMap.lookup k_fname rec of+ Just field -> renameField field rec+ Nothing -> Left (JSONError MissingField, InField k_fname : p)+ where+ k_fname = fieldKey fname+ k_fname' = fieldKey fname'+ renameField x = pure . HMap.insert k_fname' x . HMap.delete k_fname++applyChangeToData (ChChangeField _ fname _ftype tag) custom =+ withObjectField (fieldKey fname) (liftMigration $ fieldMigration custom tag)++applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p ->+ case HMap.toList un of+ [(k, r)] | k == fieldKey fname -> return $ HMap.singleton (fieldKey fname') r+ | otherwise -> return un+ _ -> Left (JSONError $ SyntaxError "Not singleton", p)++applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ ->+ if s == fieldKey fname then return (fieldKey fname')+ else return s++applyChangeToData (ChCustomRecord _ tag) custom = withObject (liftMigration $ recordMigration custom tag)+applyChangeToData (ChCustomAll tag) custom = withObject (liftMigration $ databaseMigration custom tag)++applyChangeToData (ChAddType _ _) _ = pure . pure+applyChangeToData (ChDeleteType _) _ = pure . pure+applyChangeToData (ChRenameType _ _) _ = pure . pure+applyChangeToData (ChAddUnionAlt _ _ _) _ = pure . pure+applyChangeToData (ChDeleteUnionAlt _ _) _ = pure . pure+applyChangeToData (ChAddEnumVal _ _) _ = pure . pure+applyChangeToData (ChDeleteEnumVal _ _) _ = pure . pure+++liftMigration :: (a -> Either ValueError b)+ -> (a -> Position -> Either (ValueError, Position) b)+liftMigration f v p = f v ?!? flip (,) p++-------------------------------------+-- Utils for manipulating JS.Values+--++-- | Errors that can be discovered when migrating data values+data ValueError+ = JSONError JSONError -- ^ Data doesn't match schema+ | CustomMigrationError String JS.Value -- ^ Error generated during custom migration+ | InvalidAPI ApplyFailure -- ^ An API change was invalid+ deriving (Eq, Show)++withObject :: (JS.Object -> Position -> Either (ValueError, Position) JS.Object)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withObject alter (JS.Object obj) p = JS.Object <$> alter obj p+withObject _ v p = Left (JSONError $ expectedObject v, p)++withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withObjectField field alter (JS.Object obj) p =+ case HMap.lookup field obj of+ Nothing -> Left (JSONError MissingField, InField field : p)+ Just fvalue -> JS.Object <$> (HMap.insert field+ <$> (alter fvalue (InField field : p))+ <*> pure obj)+withObjectField _ _ v p = Left (JSONError $ expectedObject v, p)++withObjectMatchingFields :: Map FieldName a+ -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withObjectMatchingFields m f (JS.Object obj) p = do+ zs <- matchMaps (Map.mapKeys fieldKey m) (hmapToMap obj) ?!? toErr+ obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs+ return $ JS.Object $ mapToHMap obj'+ where+ toErr (k, Left _) = (JSONError MissingField, InField k : p)+ toErr (k, Right _) = (JSONError UnexpectedField, InField k : p)++ hmapToMap = Map.fromList . HMap.toList++ mapToHMap = HMap.fromList . Map.toList++withObjectMatchingFields _ _ v p = Left (JSONError $ expectedObject v, p)++withObjectMatchingUnion :: Map FieldName a+ -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withObjectMatchingUnion m f (JS.Object obj) p+ | [(k, r)] <- HMap.toList obj+ = do x <- Map.lookup (fromFieldKey k) m ?! (JSONError UnexpectedField, InField k : p)+ r' <- f x r (InField k : p)+ return $ JS.Object $ HMap.singleton k r'+withObjectMatchingUnion _ _ _ p = Left (JSONError $ SyntaxError "Not singleton", p)++withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withArrayElems alter (JS.Array arr) p = JS.Array <$> V.mapM alterAt (V.indexed arr)+ where+ alterAt (i, v) = alter v (InElem i : p)+withArrayElems _ v p = Left (JSONError $ expectedArray v, p)++withMaybe :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withMaybe _ JS.Null _ = return JS.Null+withMaybe f v p = f v p++withString :: (T.Text -> Position -> Either (ValueError, Position) T.Text)+ -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+withString alter (JS.String s) p = JS.String <$> alter s p+withString _ v p = Left (JSONError $ expectedString v, p)++fieldKey :: FieldName -> T.Text+fieldKey (FieldName fname) = T.pack fname++fromFieldKey :: T.Text -> FieldName+fromFieldKey = FieldName . T.unpack++compatibleDefaultValue :: NormAPI -> APIType -> DefaultValue -> Bool+compatibleDefaultValue _ (TyList _) DefValList = True+compatibleDefaultValue _ (TyMaybe _) DefValMaybe = True+compatibleDefaultValue api (TyMaybe ty) defval = compatibleDefaultValue api ty defval+compatibleDefaultValue _ (TyBasic bt) defval =+ compatibleBasicDefaultValue bt defval+compatibleDefaultValue _ TyJSON _ = True+compatibleDefaultValue env (TyName tname) defval =+ case Map.lookup tname env of+ Just (NTypeSynonym t) -> compatibleDefaultValue env t defval+ Just (NNewtype bt) -> compatibleBasicDefaultValue bt defval+ Just (NEnumType vals) -> case defval of+ DefValString s -> fromFieldKey s `Set.member` vals+ _ -> False+ _ -> False+compatibleDefaultValue _ _ _ = False++compatibleBasicDefaultValue :: BasicType -> DefaultValue -> Bool+compatibleBasicDefaultValue BTstring (DefValString _) = True+compatibleBasicDefaultValue BTbinary (DefValString v) = case B64.decode (B.pack (T.unpack v)) of+ Left _ -> False+ Right _ -> True+compatibleBasicDefaultValue BTbool (DefValBool _) = True+compatibleBasicDefaultValue BTint (DefValInt _) = True+compatibleBasicDefaultValue BTutc (DefValUtc _) = True+compatibleBasicDefaultValue _ _ = False++-- | Check if there is a "default" default value for a field of the+-- given type: list and maybe have @[]@ and @nothing@ respectively.+-- Note that type synonyms do not preserve defaults, since we do not+-- have access to the entire API.+defaultValueForType :: APIType -> Maybe DefaultValue+defaultValueForType (TyList _) = Just DefValList+defaultValueForType (TyMaybe _) = Just DefValMaybe+defaultValueForType _ = Nothing+++-------------------------------------------+-- Validation that a dataset matches an API+--++-- | Check that a dataset matches an API, which is necessary for+-- succesful migration. The name of the dataset's type must be+-- specified.+dataMatchesAPI :: TypeName -> API -> JS.Value -> Either (ValueError, Position) ()+dataMatchesAPI root = dataMatchesNormAPI root . apiNormalForm++dataMatchesNormAPI :: TypeName -> NormAPI -> JS.Value -> Either (ValueError, Position) ()+dataMatchesNormAPI root api db = void $ valueMatches (TyName root) db []+ where+ declMatches :: NormTypeDecl -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+ declMatches (NRecordType flds) = withObjectMatchingFields flds valueMatches+ declMatches (NUnionType alts) = withObjectMatchingUnion alts valueMatches+ declMatches (NEnumType vals) = withString $ \ s p ->+ if fromFieldKey s `Set.member` vals+ then return s+ else Left (JSONError UnexpectedField, InField s : p)+ declMatches (NTypeSynonym t) = valueMatches t+ declMatches (NNewtype bt) = valueMatchesBasic bt++ valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+ valueMatches (TyList t) = withArrayElems (valueMatches t)+ valueMatches (TyMaybe t) = withMaybe (valueMatches t)+ valueMatches (TyName tname) = \ v p -> do+ d <- lookupType tname api ?!? (\ f -> (InvalidAPI f, p))+ declMatches d v p+ valueMatches (TyBasic bt) = valueMatchesBasic bt+ valueMatches TyJSON = \ v _ -> return v++ valueMatchesBasic :: BasicType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+ valueMatchesBasic BTstring = expectDecodes (fromJSONWithErrs :: Decode T.Text)+ valueMatchesBasic BTbinary = expectDecodes (fromJSONWithErrs :: Decode Binary)+ valueMatchesBasic BTbool = expectDecodes (fromJSONWithErrs :: Decode Bool)+ valueMatchesBasic BTint = expectDecodes (fromJSONWithErrs :: Decode Int)+ valueMatchesBasic BTutc = expectDecodes (fromJSONWithErrs :: Decode UTCTime)++ expectDecodes :: Decode t -> JS.Value -> Position -> Either (ValueError, Position) JS.Value+ expectDecodes f v p = case f v of+ Right _ -> return v+ Left ((je, _):_) -> Left (JSONError je, p)+ Left [] -> Left (JSONError $ SyntaxError "expectDecodes", p)++type Decode t = JS.Value -> Either [(JSONError, Position)] t++-------------------------------------+-- Utils for merging and diffing maps+--++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b+ deriving (Eq, Show)++mergeMaps :: Ord k => Map k a -> Map k b -> Map k (MergeResult a b)+mergeMaps m1 m2 = Map.unionWith (\(OnlyInLeft a) (OnlyInRight b) -> InBoth a b)+ (fmap OnlyInLeft m1) (fmap OnlyInRight m2)++diffMaps :: (Eq a, Ord k) => Map k a -> Map k a -> Map k (MergeResult a a)+diffMaps m1 m2 = Map.filter different $ mergeMaps m1 m2+ where+ different (InBoth a b) = a /= b+ different _ = True++-- Attempts to match the keys of the maps to produce a map from keys+-- to pairs.+matchMaps :: Ord k => Map k a -> Map k b -> Either (k, Either a b) (Map k (a, b))+matchMaps m1 m2 = Map.traverseWithKey win $ mergeMaps m1 m2+ where+ win _ (InBoth x y) = return (x, y)+ win k (OnlyInLeft x) = Left (k, Left x)+ win k (OnlyInRight x) = Left (k, Right x)+++-------------------------------------+-- Pretty-printing+--++prettyMigrateFailure :: MigrateFailure -> String+prettyMigrateFailure = unlines . ppLines++prettyValidateFailure :: ValidateFailure -> String+prettyValidateFailure = unlines . ppLines++prettyValueError :: ValueError -> String+prettyValueError = unlines . ppLines++prettyValueErrorPosition :: (ValueError, Position) -> String+prettyValueErrorPosition = unlines . ppLines+++instance PP TypeKind where+ pp TKRecord = "record"+ pp TKUnion = "union"+ pp TKEnum = "enum"++ppATypeKind :: TypeKind -> String+ppATypeKind TKRecord = "a record"+ppATypeKind TKUnion = "a union"+ppATypeKind TKEnum = "an enum"++ppMemberWord :: TypeKind -> String+ppMemberWord TKRecord = "field"+ppMemberWord TKUnion = "alternative"+ppMemberWord TKEnum = "value"+++instance PPLines APIChange where+ ppLines (ChAddType t d) = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d+ ppLines (ChDeleteType t) = ["removed " ++ pp t]+ ppLines (ChRenameType t t') = ["renamed " ++ pp t ++ " to " ++ pp t']+ ppLines (ChAddField t f ty mb_v) = [ "changed record " ++ pp t+ , " field added " ++ pp f ++ " :: " ++ pp ty+ ++ maybe "" (\ v -> " default " ++ pp v) mb_v]+ ppLines (ChDeleteField t f) = ["changed record " ++ pp t, " field removed " ++ pp f]+ ppLines (ChRenameField t f f') = [ "changed record " ++ pp t+ , " field renamed " ++ pp f ++ " to " ++ pp f']+ ppLines (ChChangeField t f ty c) = [ "changed record " ++ pp t+ , " field changed " ++ pp f ++ " :: " ++ pp ty+ ++ " migration " ++ pp c]+ ppLines (ChAddUnionAlt t f ty) = [ "changed union " ++ pp t+ , " alternative added " ++ pp f ++ " :: " ++ pp ty]+ ppLines (ChDeleteUnionAlt t f) = [ "changed union " ++ pp t+ , " alternative removed " ++ pp f]+ ppLines (ChRenameUnionAlt t f f') = [ "changed union " ++ pp t+ , " alternative renamed " ++ pp f ++ " to " ++ pp f']+ ppLines (ChAddEnumVal t f) = [ "changed enum " ++ pp t+ , " alternative added " ++ pp f]+ ppLines (ChDeleteEnumVal t f) = [ "changed enum " ++ pp t+ , " alternative removed " ++ pp f]+ ppLines (ChRenameEnumVal t f f') = [ "changed enum " ++ pp t+ , " alternative renamed " ++ pp f ++ " to " ++ pp f']+ ppLines (ChCustomRecord t c) = ["changed record " ++ pp t ++ " migration " ++ pp c]+ ppLines (ChCustomAll c) = ["migration " ++ pp c]++instance PPLines NormTypeDecl where+ ppLines (NRecordType flds) = "record" : map (\ (f, ty) -> " " ++ pp f+ ++ " :: " ++ pp ty)+ (Map.toList flds)+ ppLines (NUnionType alts) = "union" : map (\ (f, ty) -> " " ++ pp f+ ++ " :: " ++ pp ty)+ (Map.toList alts)+ ppLines (NEnumType vals) = "enum" : map (\ v -> " " ++ pp v)+ (Set.toList vals)+ ppLines (NTypeSynonym t) = [pp t]+ ppLines (NNewtype b) = ["basic " ++ pp b]++instance PPLines MigrateFailure where+ ppLines (ValidateFailure x) = ppLines x+ ppLines (ValueError x ps) = ppLines x ++ map prettyStep ps++instance PPLines ValidateFailure where+ ppLines (ChangelogOutOfOrder later earlier) =+ ["Changelog out of order: version " ++ pp later+ ++ " appears after version " ++ pp earlier]+ ppLines (CannotDowngrade from to) =+ ["Cannot downgrade from version " ++ pp from+ ++ " to version " ++ pp to]+ ppLines (ApiInvalid ver missing) =+ ["Missing declarations in API version " ++ pp ver ++ ": " ++ pp missing]+ ppLines (ChangelogEntryInvalid succs change af) =+ ppLines af ++ ("when applying the change" : indent (ppLines change))+ ++ if not (null succs)+ then "after successfully applying the changes:"+ : indent (ppLines succs)+ else []+ ppLines (ChangelogIncomplete ver ver' diffs) =+ ("Changelog incomplete! Differences between log version ("+ ++ showVersionExtra ver ++ ") and latest version (" ++ showVersionExtra ver' ++ "):")+ : indent (concatMap (uncurry ppDiff) $ Map.toList diffs)++instance PPLines APITableChange where+ ppLines (APIChange c _) = ppLines c+ ppLines (ValidateData _) = []++ppDiff :: TypeName -> MergeResult NormTypeDecl NormTypeDecl -> [String]+ppDiff t (OnlyInLeft _) = ["removed " ++ pp t]+ppDiff t (OnlyInRight d) = ("added " ++ pp t ++ " ") `inFrontOf` ppLines d+ppDiff t (InBoth (NRecordType flds) (NRecordType flds')) =+ ("changed record " ++ pp t)+ : (concatMap (uncurry (ppDiffFields "field")) $ Map.toList $ diffMaps flds flds')+ppDiff t (InBoth (NUnionType alts) (NUnionType alts')) =+ ("changed union " ++ pp t)+ : (concatMap (uncurry (ppDiffFields "alternative")) $ Map.toList $ diffMaps alts alts')+ppDiff t (InBoth (NEnumType vals) (NEnumType vals')) =+ ("changed enum " ++ pp t)+ : (map (\ x -> " alternative removed " ++ pp x) $ Set.toList $ vals Set.\\ vals')+ ++ (map (\ x -> " alternative added " ++ pp x) $ Set.toList $ vals' Set.\\ vals)+ppDiff t (InBoth _ _) = ["incompatible definitions of " ++ pp t]++ppDiffFields :: String -> FieldName -> MergeResult APIType APIType -> [String]+ppDiffFields s f (OnlyInLeft _) = [" " ++ s ++ " removed " ++ pp f]+ppDiffFields s f (OnlyInRight ty) = [" " ++ s ++ " added " ++ pp f ++ " :: " ++ pp ty]+ppDiffFields s f (InBoth ty ty') = [ " incompatible types for " ++ s ++ " " ++ pp f+ , " changelog type: " ++ pp ty+ , " latest version type: " ++ pp ty' ]+++instance PPLines ApplyFailure where+ ppLines (TypeExists t) = ["Type " ++ pp t ++ " already exists"]+ ppLines (TypeDoesNotExist t) = ["Type " ++ pp t ++ " does not exist"]+ ppLines (TypeWrongKind t k) = ["Type " ++ pp t ++ " is not " ++ ppATypeKind k]+ ppLines (TypeInUse t) = ["Type " ++ pp t ++ " is in use, so it cannot be modified"]+ ppLines (TypeMalformed ty xs) = ["Type " ++ pp ty+ ++ " is malformed, missing declarations:"+ , " " ++ pp xs]+ ppLines (DeclMalformed t _ xs) = [ "Declaration of " ++ pp t+ ++ " is malformed, missing declarations:"+ , " " ++ pp xs]+ ppLines (FieldExists t k f) = ["Type " ++ pp t ++ " already has the "+ ++ ppMemberWord k ++ " " ++ pp f]+ ppLines (FieldDoesNotExist t k f) = ["Type " ++ pp t ++ " does not have the "+ ++ ppMemberWord k ++ " " ++ pp f]+ ppLines (FieldBadDefaultValue _ _ ty v) = ["Default value " ++ pp v+ ++ " is not compatible with the type " ++ pp ty]+ ppLines (DefaultMissing t f) = ["Field " ++ pp f ++ " does not have a default value, but "+ ++ pp t ++ " occurs in the database"]+ ppLines (TableChangeError s) = ["Error when detecting changed tables:", " " ++ s]+++instance PPLines ValueError where+ ppLines (JSONError e) = [prettyJSONError e]+ ppLines (CustomMigrationError e v) = [ "Custom migration error:", " " ++ e+ , "when migrating value"] ++ indent (ppLines v)+ ppLines (InvalidAPI af) = "Invalid API detected during value migration:"+ : indent (ppLines af)+++-------------------------------------+-- Template Haskell+--++-- | Generate enumeration datatypes corresponding to the custom+-- migrations used in an API migration changelog.+generateMigrationKinds :: APIChangelog -> String -> String -> String -> Q [Dec]+generateMigrationKinds changes all_nm rec_nm fld_nm = do+ guardNoDups (all_tags `Set.intersection` rec_tags)+ guardNoDups (all_tags `Set.intersection` fld_tags)+ guardNoDups (rec_tags `Set.intersection` fld_tags)++ return [ DataD [] (mkName all_nm) [] (cons all_nm all_tags) derivs+ , DataD [] (mkName rec_nm) [] (cons rec_nm rec_tags) derivs+ , DataD [] (mkName fld_nm) [] (cons fld_nm fld_tags) derivs ]+ where+ (all_tags, rec_tags, fld_tags) = changelogTags changes++ guardNoDups xs+ | Set.null xs = return ()+ | otherwise = fail $ "generateMigrationKinds: duplicate custom migrations in changelog: "+ ++ show (Set.toList xs)++ -- List of constructors must not be empty, otherwise GHC can't+ -- derive Read/Show instances (see GHC Trac #7401)+ cons s xs | not (Set.null xs) = map (\ x -> NormalC (mkName x) []) (Set.toList xs)+ | otherwise = [NormalC (mkName $ "No" ++ s) []]++ derivs = [''Read, ''Show]
+ src/Data/API/Doc.hs view
@@ -0,0 +1,21 @@+module Data.API.Doc+ ( callHtml+ , dirHtml+ , Call(..)+ , Header(..)+ , Param(..)+ , View(..)+ , Sample(..)+ , Body(..)+ , DocInfo(..)+ , URL+ , HTTPMethod+ , StatusCode+ , renderAPIType+ , renderBodyType+ , mk_link+ ) where++import Data.API.Doc.Call+import Data.API.Doc.Dir+import Data.API.Doc.Types
+ src/Data/API/Doc/Call.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Data.API.Doc.Call+ ( callHtml+ ) where++import Data.API.Doc.Subst+import Data.API.Doc.Types++import Data.List+import Data.Ord+++-- | Generate a web page documenting a 'Call'+callHtml :: DocInfo -> Dict -> Call -> String+callHtml di dct0 call@Call{..} = concat+ [ container_open dct+ , headersHtml di call dct+ , paramsHtml di call dct+ , bodyHtml di call dct+ , viewsHtml di call dct+ , samplesHtml di call dct+ ]+ where+ dct = flip extDict dct0+ [ (,) "HTTP-METHOD" $ call_http_method+ , (,) "PATH" $ ('/' :) $ concat $ intersperse "/" call_path+ , (,) "CALL-DESCRIPTION" call_description+ , (,) "AUTH-REQUIRED" $ if call_auth_required then "yes" else "no"+ ]++headersHtml :: DocInfo -> Call -> Dict -> String+headersHtml di Call{..} c_dct =+ case call_headers of+ [] -> ""+ _ -> concat+ [ headers_head+ , concatMap mk_header $ sortBy (comparing header_name) call_headers+ , headers_foot+ ]+ where+ mk_header hdr = header_content $ call_dict_header di c_dct hdr+++paramsHtml :: DocInfo -> Call -> Dict -> String+paramsHtml di Call{..} c_dct =+ case call_params of+ [] -> no_params c_dct+ _ -> concat+ [ params_head c_dct+ , paramsRows di c_dct call_params+ , params_foot c_dct+ ]++paramsRows :: DocInfo -> Dict -> [Param] -> String+paramsRows di c_dct = concatMap mk_param . sortBy (comparing param_name)+ where+ mk_param param = parameter_row $ call_dict_param di c_dct param++bodyHtml :: DocInfo -> Call -> Dict -> String+bodyHtml di Call{..} c_dct =+ case call_body of+ Nothing -> ""+ Just (typ,spl) ->+ body_sample $+ flip extDict c_dct+ [ (,) "BODY-TYPE" (renderAPIType di typ)+ , (,) "BODY-SAMPLE" spl+ ]++viewsHtml :: DocInfo -> Call -> Dict -> String+viewsHtml di Call{..} c_dct+ | null call_views = ""+ | otherwise = concat [ views_head+ , concatMap (view_content . view_dict) call_views+ , views_foot+ , concatMap view_detailed call_views+ ]+ where+ view_dict vw = flip extDict c_dct+ [ (,) "VIEW-ID" $ view_id vw+ , (,) "VIEW-TYPE" $ renderAPIType di $ view_type vw+ , (,) "VIEW-DOC" $ view_doc vw+ ]++ view_detailed vw+ | null (view_params vw) = ""+ | otherwise = concat [ view_detail_head v_dct+ , paramsRows di v_dct $ view_params vw+ , view_detail_foot+ ]+ where v_dct = view_dict vw++samplesHtml :: DocInfo -> Call -> Dict -> String+samplesHtml di Call{..} c_dct = concat+ [ sample_heading c_dct+ , concat $ map mk_sample call_samples+ ]+ where+ mk_sample spl = sample s_dct+ where+ s_dct = call_dict_sample di c_dct spl++call_dict_header :: DocInfo -> Dict -> Header -> Dict+call_dict_header di dct Header{..} = flip extDict dct+ [ (,) "HEADER-NAME" header_name+ , (,) "HEADER-OR" $ if header_required then "Required" else "Optional"+ , (,) "HEADER-EXAMPLE" header_expl+ , (,) "HEADER-DESC" header_desc+ , (,) "HEADER-TYPE" $ renderAPIType di header_type+ ]++call_dict_param :: DocInfo -> Dict -> Param -> Dict+call_dict_param di dct Param{..} = flip extDict dct+ [ (,) "PARAMETER-NAME" param_name+ , (,) "PARAMETER-OR" $ if param_required then "Required" else "Optional"+ , (,) "PARAMETER-EXAMPLE" param_expl+ , (,) "PARAMETER-DESC" param_desc+ , (,) "PARAMETER-TYPE" $ either id (renderAPIType di) param_type+ ]++call_dict_sample :: DocInfo -> Dict -> Sample -> Dict+call_dict_sample di dct Sample{..} = flip extDict dct+ [ (,) "HTTP-STATUS" $ show sample_status+ , (,) "SAMPLE-TYPE" $ renderBodyType di sample_type+ , (,) "SAMPLE-RESPONSE" $ maybe "" id sample_response+ ]+++container_open :: Dict -> String+container_open dct = prep dct+ [ " <nav class='breadcrumbs'>"+ , " <a href='<<BC-HOME-URL>>'><<BC-HOME-TEXT>></a> » <<HTTP-METHOD>> <<PATH>>"+ , " </nav>"+ , " <h2>"+ , " <<HTTP-METHOD>> <<PATH>>"+ , " </h2>"+ , " <br>"+ , " <div class='description'>"+ , " <p><<CALL-DESCRIPTION>></p>"+ , " </div>"+ , " <table border='0' cellspacing='3' cellpadding='0' class='details-table'>"+ , " <tr>"+ , " <td width='180'><strong>Request Method</strong></td>"+ , " <td><code><<HTTP-METHOD>></code> </td>"+ , " </tr>"+ , " <tr>"+ , " <td width='180'><strong>Resource URI</strong></td>"+ , " <td><code><<ENDPOINT>><<PATH>></code> </td>"+ , " </tr>"+ , " <tr>"+ , " <td width='180'><strong>Authentication Required</strong></td>"+ , " <td><code>"+ , " <<AUTH-REQUIRED>>"+ , " </code> "+ , " </td>"+ , " </tr>"+-- , " <tr>"+-- , " <td width='180'><strong>Request Body</strong></td>"+-- , " <td><b>" ++ mkLink dct "POST-NODE-URL" "POST-NODE" ++ "</b></td>"+-- , " </tr>"+ , " </table>"+ , " <br>"+ , " <hr/>"+ ]++headers_head :: String+headers_head = unlines+ [ " <br>"+ , " <h3>Headers</h3>"+ , " <br>"+ , " <table border='0' cellspacing='0' cellpadding='0' width='100%' id='headers'>"+ ]++header_content :: Dict -> String+header_content dct = prep dct+ [ " <tr>"+ , " <td><code><<HEADER-NAME>></code></td>"+ , " <td><em><<HEADER-OR>></em></td>"+ , " <td class='details'><p><<HEADER-TYPE>></p></td>"+ , " <td class='details'><p><tt><<HEADER-EXAMPLE>></tt></p></td>"+ , " <td class='details'><p><<HEADER-DESC>></p></td>"+ , " </tr>"+ ]++headers_foot :: String+headers_foot = "</table><br>"+++no_params :: Dict -> String+no_params dct = prep dct+ [ " <br>"+ , " <h3>Parameters</h3>"+ , " <br>"+ , " <em>There are no parameters for this resource.</em>"+ , " <br>"+ ]++params_head :: Dict -> String+params_head dct = prep dct+ [ " <br>"+ , " <h3>Parameters</h3>"+ , " <br>"+ , " <table border='0' cellspacing='0' cellpadding='0' width='100%' id='params' class='params'>"+ ]++++parameter_row :: Dict -> String+parameter_row dct = prep dct+ [ " <tr>"+ , " <td width='130'><code><<PARAMETER-NAME>></code></td>"+ , " <td width='75'>"+ , " <em>"+ , " <<PARAMETER-OR>>"+ , " </em>"+ , " </td>"+ , " <td class='details'>"+ , " <p><<PARAMETER-TYPE>></p>"+ , " </td>"+ , " <td class='details'>"+ , " <p><tt><<PARAMETER-EXAMPLE>></tt></p>"+ , " </td>"+ , " <td class='details'>"+ , " <p><<PARAMETER-DESC>></p>"+ , " </td>"+ , " </tr>"+ ]+++params_foot :: Dict -> String+params_foot dct = prep dct+ [ " </table>"+ ]++body_sample :: Dict -> String+body_sample dct = prep dct+ [ " <br>"+ , " <h3>Sample Body</h3>"+ , " <br>"+ , " <div class='response-format'>"+ , " <<BODY-TYPE>>"+ , " </div>"+ , " <pre><<BODY-SAMPLE>></pre>"+ ]+++views_head :: String+views_head = unlines+ [ " <br>"+ , " <h3>Views</h3>"+ , " <br>"+ , " <table border='0' cellspacing='0' cellpadding='0' width='100%' id='views'>"+ ]++view_content :: Dict -> String+view_content dct = prep dct+ [ " <tr>"+ , " <td width='130'><code><<VIEW-ID>></code></td>"+ , " <td class='details'><p><<VIEW-TYPE>></p></td>"+ , " <td class='details'><p><<VIEW-DOC>></p></td>"+ , " </tr>"+ ]++views_foot :: String+views_foot = "</table><br>"+++view_detail_head :: Dict -> String+view_detail_head dct = prep dct+ [ " <br>"+ , " <h3>Parameters for <code><<VIEW-ID>></code> view :: <<VIEW-TYPE>></h3>"+ , " <br>"+ , " <table border='0' cellspacing='0' cellpadding='0' width='100%' class='params view-detail' id='view-<<VIEW-ID>>'>"+ ]++view_detail_foot :: String+view_detail_foot = "</table>"++++sample_heading :: Dict -> String+sample_heading dct = prep dct+ [ " <br>"+ , " <h3>Sample Responses</h3>"+ , " <br>"+ ]++sample :: Dict -> String+sample dct = prep dct+ [ " <div class='response-format'>"+ , " <<SAMPLE-TYPE>>"+ , " <span>HTTP Status: <<HTTP-STATUS>></span>"+ , " </div>"+ , " <pre><<SAMPLE-RESPONSE>></pre>"+ ]
+ src/Data/API/Doc/Dir.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Data.API.Doc.Dir+ ( dirHtml+ ) where++import Data.API.Doc.Types+import Data.API.Doc.Subst+import Data.List+import Data.Ord+import Data.Char+++-- | Generate a web page documenting all the 'Call's in a web+-- application+dirHtml :: DocInfo -> Dict -> [Call] -> String+dirHtml di dct cls = concat+ [ container_open dct+ , concat $ map (resourceHtml di dct) $ aggregate cls+ ]++aggregate :: [Call] -> [(String,[Call])]+aggregate = map f . groupBy eq . sortBy (comparing fst) . map x_r+ where+ x_r cl@Call{..} =+ case call_path of+ [] -> ("/" ,cl)+ rsrc:_ -> (rsrc,cl)++ eq (x,_) (y,_) = x==y++ f [] = error "Data.API.Doc.Dir.aggregate"+ f ((rsrc,cl):ps) = (rsrc,cl:map snd ps)+++resourceHtml :: DocInfo -> Dict -> (String,[Call]) -> String+resourceHtml di dct (rsc,cls) = concat+ [ resource_heading r_dct+ , ul_open r_dct+ , concat [ callHtml di r_dct cl | cl<-cls ]+ , ul_close r_dct+ ]+ where+ r_dct = resource_dict dct rsc++resource_dict :: Dict -> String -> Dict+resource_dict dct rsc = flip extDict dct+ [ (,) "RESOURCE-HEADING" rsc+ ]++callHtml :: DocInfo -> Dict -> Call -> String+callHtml di dct cl = call $ call_dict di dct cl++call_dict :: DocInfo -> Dict -> Call -> Dict+call_dict di dct Call{..} = flip extDict dct+ -- calls+ [ (,) "CALL-URL" $ doc_info_call_url di call_http_method call_path+ , (,) "METHOD-CLASS" $ map toLower mth_s+ , (,) "METHOD" $ mth_s+ , (,) "PATH" $ '/' : concat (intersperse "/" call_path)+ , (,) "BODY-TYPE" $ maybe "—" (renderAPIType di . fst) call_body+ ]+ where+ mth_s = call_http_method+-- cvt = T.unpack . _APINodeName++container_open :: Dict -> String+container_open dct = prep dct+ [ "<h2>"+ , " <<TITLE>>"+ , " <span class='tagline'><<TAGLINE>></span>"+ , "</h2>"+ , "<strong>Endpoint: </strong><<ENDPOINT>>"+ , "<br>"+ , "<div id='toc'>"+ , " <div id='app-description'>"+ , " <p><<SUMMARY>></p>"+ , " </div>"+ , " <hr/>"+ , " <br>"+ , " <h3 class='section-title'>"+ , " API Resources for This Application"+ , " </h3>"+ ]++resource_heading :: Dict -> String+resource_heading dct = prep dct+ [ " <h5 class='tag'><<RESOURCE-HEADING>></h5>"+ ]++ul_open :: Dict -> String+ul_open dct = prep dct+ [ " <ul class='list resource-list'>"+ ]++call :: Dict -> String+call dct = prep dct+ [ " <li >"+ , " <a class='reflink' href='<<CALL-URL>>'>"+ , " <span class='<<METHOD-CLASS>>'><<METHOD>></span>"+ , " <<PATH>>"+ , " </a>"+ , " <div class='post-data' ><<BODY-TYPE>></div>"+ , " </li>"+ ]++ul_close :: Dict -> String+ul_close dct = prep dct+ [ " </ul>"+ ]
+ src/Data/API/Doc/Subst.hs view
@@ -0,0 +1,40 @@+module Data.API.Doc.Subst+ ( Dict+ , subst+ , prep+ , mkDict+ , extDict+ )+ where++import qualified Data.Map as Map+import Text.Regex+import Safe+++type Dict = Map.Map String String+++subst_re :: Regex+subst_re = mkRegexWithOpts "<<[a-zA-Z0-9_'-]+>>" True True++subst :: Dict -> String -> String+subst dct str =+ case matchRegexAll subst_re str of+ Nothing -> str+ Just (pre,var_,pst,_) -> pre ++ rpl ++ subst dct pst+ where+ rpl = maybe ("<<"++var++">>") id $ Map.lookup var dct++ var = chp $ reverse $ chp $ reverse var_+ + chp = tailNote "subst.chp" . tailNote "subst.chp"++prep :: Dict -> [String] -> String+prep dct = unlines . map (subst dct) ++mkDict :: [(String,String)] -> Dict+mkDict = Map.fromList++extDict :: [(String,String)] -> Dict -> Dict+extDict al dct = foldr (uncurry Map.insert) dct al
+ src/Data/API/Doc/Types.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Data.API.Doc.Types+ ( URL+ , HTTPMethod+ , StatusCode+ , Call(..)+ , Header(..)+ , Param(..)+ , View(..)+ , Sample(..)+ , Body(..)+ , DocInfo(..)+ , renderAPIType+ , renderBodyType+ , mk_link+ ) where++import Data.API.Types++import Text.Printf++type URL = String+type HTTPMethod = String+type StatusCode = Int++-- | Documents a single method call on a resource in a web application+data Call+ = Call+ { call_http_method :: HTTPMethod -- ^ HTTP method being documented+ , call_path :: [String] -- ^ Relative URL path of the resource+ , call_description :: String -- ^ Free-form text description+ , call_auth_required :: Bool -- ^ Does the call require authentication?+ , call_headers :: [Header] -- ^ HTTP headers relevant to the call+ , call_body :: Maybe (APIType, String) -- ^ Type and example of request body+ , call_params :: [Param] -- ^ Query parameters relevant to the call+ , call_views :: [View] -- ^ Available views of the result data+ , call_samples :: [Sample] -- ^ Example responses+ }+ deriving (Show)++-- | Documents a HTTP header that may be supplied to a 'Call'+data Header+ = Header+ { header_name :: String -- ^ Header name+ , header_expl :: String -- ^ Example value for header+ , header_desc :: String -- ^ Free-form text description+ , header_type :: APIType -- ^ Type of data in header+ , header_required :: Bool -- ^ Is including the header with the request mandatory?+ } deriving (Show)++-- | Documents a URL query parameter that may be included with a 'Call'+data Param+ = Param+ { param_name :: String -- ^ Parameter name+ , param_expl :: String -- ^ Example value for parameter+ , param_desc :: String -- ^ Free-form text description+ , param_type :: Either String APIType -- ^ Type of data in the parameter+ , param_required :: Bool -- ^ Is including the parameter mandatory?+ } deriving (Show)++-- | Documents a specific view of the result data available in a 'Call'+data View+ = View+ { view_id :: String -- ^ View name+ , view_type :: APIType -- ^ Type of result data returned+ , view_doc :: String -- ^ Free-form text description+ , view_params :: [Param] -- ^ Query parameters that may be supplied for this view+ } deriving (Show)++-- | Example response data from a 'Call'+data Sample+ = Sample+ { sample_status :: StatusCode -- ^ HTTP status code for this example response+ , sample_type :: Body APIType -- ^ Type of example response+ , sample_response :: Maybe String -- ^ Content of response, or 'Nothing' for empty response+ } deriving (Show)++-- | Type for 'Sample' response body, parameterised by possible JSON types+data Body t = EmptyBody -- ^ An empty response+ | JSONBody t -- ^ A JSON response of the given type+ | OtherBody String -- ^ A non-empty, non-JSON response+ deriving (Functor, Show)++-- | Record of arguments that must be supplied to generate HTML+-- documentation for a 'Call'+data DocInfo+ = DocInfo+ { doc_info_call_url :: HTTPMethod -> [String] -> URL+ -- ^ URL for individual call documentation from the index+ , doc_info_type_url :: TypeName -> URL+ -- ^ URL for documentation of an API type+ }++renderBodyType :: DocInfo -> Body APIType -> String+renderBodyType _ EmptyBody = "empty"+renderBodyType di (JSONBody ty) = "json " ++ renderAPIType di ty+renderBodyType _ (OtherBody s) = s++renderAPIType :: DocInfo -> APIType -> String+renderAPIType di (TyList ty ) = "[" ++ renderAPIType di ty ++ "]"+renderAPIType di (TyMaybe ty ) = "?" ++ renderAPIType di ty+renderAPIType di (TyName tn ) = mk_link (doc_info_type_url di tn) (_TypeName tn)+renderAPIType _ (TyBasic bt ) = renderBasicType bt+renderAPIType _ TyJSON = "json"++renderBasicType :: BasicType -> String+renderBasicType BTstring{} = "string"+renderBasicType BTbinary{} = "binary"+renderBasicType BTbool {} = "bool"+renderBasicType BTint {} = "int"+renderBasicType BTutc {} = "utc"++mk_link :: URL -> String -> String+mk_link = printf "<b><a class='reflink' href='%s' >%s</a></b>"
+ src/Data/API/JSON.hs view
@@ -0,0 +1,415 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | This module defines a JSON parser, like Aeson's 'FromJSON', but+-- with more detailed error-reporting capabilities. In particular, it+-- reports errors in a structured format, and can report multiple+-- independent errors rather than stopping on the first one+-- encountered.+module Data.API.JSON+ ( -- * Representation of JSON parsing errors+ JSONError(..)+ , Expected(..)+ , FormatExpected(..)+ , Position+ , Step(..)+ , prettyJSONErrorPositions+ , prettyJSONError+ , prettyStep++ -- * Parser with multiple error support+ , ParserWithErrs+ , runParserWithErrsTop++ -- * FromJSON class with multiple error support+ , FromJSONWithErrs(..)+ , fromJSONWithErrs+ , decodeWithErrs++ -- * ParserWithErrs combinators+ , failWith+ , expectedArray+ , expectedBool+ , expectedInt+ , expectedObject+ , expectedString+ , badFormat+ , withInt+ , withNum+ , withIntRange+ , withBinary+ , withBool+ , withText+ , withRegEx+ , withUTC+ , withUTCRange+ , withVersion+ , withField+ , (.:.)+ , (.::)+ ) where++import Data.API.Types+import Data.API.Utils++import Control.Applicative+import qualified Data.Aeson as JS+import Data.Aeson.TH+import Data.Attoparsec.Number+import Data.Attoparsec.Text+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HMap+import Data.List+import Data.Maybe+import qualified Data.SafeCopy as SC+import qualified Data.Text as T+import Data.Time+import Data.Traversable+import qualified Data.Vector as V+import Data.Version+import Distribution.Text+import Text.Regex++----------------------------------------------------------+-- Representation of JSON parsing errors and positions+--++-- | Represents an error that can be encountered while parsing+data JSONError = Expected Expected String JS.Value+ | BadFormat FormatExpected String T.Text+ | MissingField+ | MissingAlt [String]+ | UnexpectedField+ | UnexpectedEnumVal [T.Text] T.Text+ | IntRangeError String Int IntRange+ | UTCRangeError String UTCTime UTCRange+ | RegexError String T.Text RegEx+ | SyntaxError String+ deriving (Eq, Show)++-- | JSON type expected at a particular position, when a value of a+-- different type was encountered+data Expected = ExpArray+ | ExpBool+ | ExpInt+ | ExpObject+ | ExpString+ deriving (Eq, Show)++-- | Special format expected of a string+data FormatExpected = FmtBinary+ | FmtUTC+ | FmtOther+ deriving (Eq, Show)++expectedArray, expectedBool, expectedInt, expectedObject, expectedString+ :: JS.Value -> JSONError+expectedArray = Expected ExpArray "Array"+expectedBool = Expected ExpBool "Bool"+expectedInt = Expected ExpInt "Int"+expectedObject = Expected ExpObject "Object"+expectedString = Expected ExpString "String"++badFormat :: String -> T.Text -> JSONError+badFormat = BadFormat FmtOther++-- | Human-readable description of a JSON parse error+prettyJSONError :: JSONError -> String+prettyJSONError (Expected _ s v) = "When expecting " ++ s ++ ", encountered "+ ++ x ++ " instead"+ where+ x = case v of+ JS.Object _ -> "Object"+ JS.Array _ -> "Array"+ JS.String _ -> "String"+ JS.Number _ -> "Number"+ JS.Bool _ -> "Boolean"+ JS.Null -> "Null"+prettyJSONError (BadFormat _ s t) = "Could not parse as " ++ s ++ " the string " ++ show t+prettyJSONError MissingField = "Field missing from Object"+prettyJSONError (MissingAlt xs) = "Missing alternative, expecting one of: "+ ++ intercalate ", " xs+prettyJSONError UnexpectedField = "Unexpected field in Object"+prettyJSONError (UnexpectedEnumVal xs t) = "Unexpected enum value " ++ show t+ ++ ", expecting one of: "+ ++ T.unpack (T.intercalate ", " xs)+prettyJSONError (IntRangeError s i r) = s ++ ": " ++ show i ++ " not in range " ++ show r+prettyJSONError (UTCRangeError s u r) = s ++ ": " ++ show u ++ " not in range " ++ show r+prettyJSONError (RegexError s _ t) = s ++ ": failed to match RE: " ++ show t+prettyJSONError (SyntaxError e) = "JSON syntax error: " ++ e++-- | A position inside a JSON value is a list of steps, ordered+-- innermost first (so going inside an object prepends a step).+type Position = [Step]++-- | Each step may be into a field of an object, or a specific element+-- of an array.+data Step = InField T.Text | InElem Int+ deriving (Eq, Show)++-- | Human-readable description of a single step in a position+prettyStep :: Step -> String+prettyStep (InField f) = " in the field " ++ show f+prettyStep (InElem i) = " in array index " ++ show i++-- | Human-readable presentation of a list of parse errors with their+-- positions+prettyJSONErrorPositions :: [(JSONError, Position)] -> String+prettyJSONErrorPositions xs = unlines $ concatMap help xs+ where+ help (e, pos) = prettyJSONError e : map prettyStep pos+++----------------------------------------+-- Parser with multiple error support+--++-- | Like 'Parser', but keeping track of locations within the JSON+-- structure and able to report multiple errors.+--+-- Careful! The 'Monad' instance does not agree with the 'Applicative'+-- instance in all circumstances, and you should use the 'Applicative'+-- instance where possible. In particular:+--+-- * @pf \<*\> ps@ returns errors from both arguments+--+-- * @pf \`ap\` ps@ returns errors from @pf@ only+newtype ParserWithErrs a = ParserWithErrs {+ runParserWithErrs :: Position -> Either [(JSONError, Position)] a }+ deriving Functor++instance Applicative ParserWithErrs where+ pure x = ParserWithErrs $ const $ Right x+ pf <*> ps = ParserWithErrs $ \ z ->+ case (runParserWithErrs pf z, runParserWithErrs ps z) of+ (Right f, Right s) -> Right $ f s+ (Left es, Right _) -> Left es+ (Right _, Left es) -> Left es+ (Left es, Left es') -> Left $ es ++ es'++instance Alternative ParserWithErrs where+ empty = failWith $ SyntaxError "No alternative"+ px <|> py = ParserWithErrs $ \ z -> case runParserWithErrs px z of+ Right v -> Right v+ Left _ -> runParserWithErrs py z++instance Monad ParserWithErrs where+ return = pure+ px >>= f = ParserWithErrs $ \ z ->+ case runParserWithErrs px z of+ Right x -> runParserWithErrs (f x) z+ Left es -> Left es+ fail = failWith . SyntaxError++runParserWithErrsTop :: ParserWithErrs a -> Either [(JSONError, Position)] a+runParserWithErrsTop p = runParserWithErrs p []+++--------------------------------------------------+-- FromJSON class with multiple error support+--++-- | Like 'FromJSON', but keeping track of multiple errors and their+-- positions. Moreover, this class is more liberal in accepting+-- invalid inputs:+--+-- * a string like @\"3\"@ is accepted as an integer; and+--+-- * the integers @0@ and @1@ are accepted as booleans.++class FromJSONWithErrs a where+ -- | Parse a JSON value with structured error-reporting support. If+ -- this method is omitted, 'fromJSON' will be used instead: note+ -- that this will result in less precise errors.+ parseJSONWithErrs :: JS.Value -> ParserWithErrs a+ default parseJSONWithErrs :: JS.FromJSON a => JS.Value -> ParserWithErrs a+ parseJSONWithErrs v = case JS.fromJSON v of+ JS.Error e -> failWith $ SyntaxError e+ JS.Success a -> pure a++instance FromJSONWithErrs JS.Value where+ parseJSONWithErrs = pure++instance FromJSONWithErrs () where+ parseJSONWithErrs (JS.Array a) | V.null a = pure ()+ parseJSONWithErrs _ = failWith $ SyntaxError "Expected empty array"++instance FromJSONWithErrs a => FromJSONWithErrs (Maybe a) where+ parseJSONWithErrs JS.Null = pure Nothing+ parseJSONWithErrs v = Just <$> parseJSONWithErrs v++instance FromJSONWithErrs a => FromJSONWithErrs [a] where+ parseJSONWithErrs (JS.Array a) = traverse help $ zip (V.toList a) [0..]+ where+ help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x+ parseJSONWithErrs v = failWith $ expectedArray v++instance FromJSONWithErrs Int where+ parseJSONWithErrs = withInt "Int" pure++instance FromJSONWithErrs Integer where+ parseJSONWithErrs = withNum "Integer" pure++instance FromJSONWithErrs Bool where+ parseJSONWithErrs = withBool "Bool" pure++instance FromJSONWithErrs Binary where+ parseJSONWithErrs = withBinary "Binary" pure++instance FromJSONWithErrs T.Text where+ parseJSONWithErrs = withText "Text" pure++instance FromJSONWithErrs UTCTime where+ parseJSONWithErrs = withUTC "UTC" pure++instance FromJSONWithErrs Version where+ parseJSONWithErrs = withVersion "Version" pure+++-- | Run the JSON parser on a value to produce a result or a list of+-- errors with their positions. This should not be used inside an+-- implementation of 'parseJSONWithErrs' as it will not pass on the+-- current position.+fromJSONWithErrs :: FromJSONWithErrs a => JS.Value -> Either [(JSONError, Position)] a+fromJSONWithErrs = runParserWithErrsTop . parseJSONWithErrs++-- | Decode a 'ByteString' and run the JSON parser+decodeWithErrs :: FromJSONWithErrs a => BL.ByteString -> Either [(JSONError, Position)] a+decodeWithErrs x = case JS.eitherDecode x of+ Left e -> Left [(SyntaxError e, [])]+ Right v -> fromJSONWithErrs v+++---------------------------------+-- ParserWithErrs combinators+--++failWith :: JSONError -> ParserWithErrs a+failWith e = ParserWithErrs $ \ z -> Left [(e, z)]++stepInside :: Step -> ParserWithErrs a -> ParserWithErrs a+stepInside s p = ParserWithErrs $ \ z -> runParserWithErrs p (s:z)++-- | If this parser returns any errors at the current position, modify+-- them using the supplied function.+modifyTopError :: (JSONError -> JSONError)+ -> ParserWithErrs a -> ParserWithErrs a+modifyTopError f p = ParserWithErrs $ \ z -> case runParserWithErrs p z of+ Left es -> Left $ map (modifyIfAt z) es+ r -> r+ where+ modifyIfAt z x@(e, z') | z == z' = (f e, z')+ | otherwise = x+++-- It's contrary to my principles, but I'll accept a string containing+-- a number instead of an actual number...+withInt :: String -> (Int -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a+withInt = withNum++withNum :: Num n => String -> (n -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a+withNum _ f (JS.Number (I n)) = f (fromInteger n)+withNum _ f (JS.String s)+ | Right (I n) <- parseOnly (number <* endOfInput) s = f (fromInteger n)+withNum s _ v = failWith $ Expected ExpInt s v++withIntRange :: IntRange -> String -> (Int -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withIntRange ir dg f = withInt dg g+ where+ g i | i `inIntRange` ir = f i+ | otherwise = failWith $ IntRangeError dg i ir++ _ `inIntRange` IntRange Nothing Nothing = True+ i `inIntRange` IntRange (Just lo) Nothing = lo <= i+ i `inIntRange` IntRange Nothing (Just hi) = i <= hi+ i `inIntRange` IntRange (Just lo) (Just hi) = lo <= i && i <= hi++withBinary :: String -> (Binary -> ParserWithErrs a) -> JS.Value -> ParserWithErrs a+withBinary lab f = withText lab g+ where+ g t =+ case B64.decode $ B.pack $ T.unpack t of+ Left _ -> failWith $ BadFormat FmtBinary lab t+ Right bs -> f $ Binary bs++-- Everyone knows 0 and 1 are booleans really...+withBool :: String -> (Bool -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withBool _ f (JS.Bool b) = f b+withBool _ f (JS.Number (I i)) | i == 0 = f False+ | i == 1 = f True+withBool s _ v = failWith $ Expected ExpBool s v++withText :: String -> (T.Text -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withText _ f (JS.String t) = f t+withText s _ v = failWith $ Expected ExpString s v++withRegEx :: RegEx -> String -> (T.Text -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withRegEx re dg f = withText dg g+ where+ g txt = case matchRegex (re_regex re) $ T.unpack txt of+ Just _ -> f txt+ Nothing -> failWith $ RegexError dg txt re++withUTC :: String -> (UTCTime -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withUTC lab f = withText lab g+ where+ g t = maybe (failWith $ BadFormat FmtUTC lab t) f $ parseUTC' t++withUTCRange :: UTCRange -> String -> (UTCTime -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withUTCRange ur dg f = withUTC dg g+ where+ g u | u `inUTCRange` ur = f u+ | otherwise = failWith $ UTCRangeError dg u ur++ _ `inUTCRange` UTCRange Nothing Nothing = True+ u `inUTCRange` UTCRange (Just lo) Nothing = lo <= u+ u `inUTCRange` UTCRange Nothing (Just hi) = u <= hi+ u `inUTCRange` UTCRange (Just lo) (Just hi) = lo <= u && u <= hi++withVersion :: String -> (Version -> ParserWithErrs a)+ -> JS.Value -> ParserWithErrs a+withVersion lab f (JS.String s) = case simpleParse $ T.unpack s of+ Just ver -> f ver+ Nothing -> failWith $ badFormat lab s+withVersion lab _ v = failWith $ Expected ExpString lab v++-- | Look up the value of a field, treating missing fields as null+withField :: T.Text -> (JS.Value -> ParserWithErrs a)+ -> JS.Object -> ParserWithErrs a+withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v+ where+ v = fromMaybe JS.Null $ HMap.lookup k m+ treatAsMissing (Expected _ _ JS.Null) = MissingField+ treatAsMissing e = e++-- | Look up the value of a field, failing on missing fields+withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a)+ -> JS.Object -> ParserWithErrs a+withStrictField k f m = stepInside (InField k) $ case HMap.lookup k m of+ Nothing -> failWith MissingField+ Just r -> f r++-- | Parse the value of a field, treating missing fields as null+(.:.) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a+m .:. k = withField k parseJSONWithErrs m++-- | Parse the value of a field, failing on missing fields+(.::) :: FromJSONWithErrs a => JS.Object -> T.Text -> ParserWithErrs a+m .:: k = withStrictField k parseJSONWithErrs m+++deriveJSON defaultOptions ''JSONError+deriveJSON defaultOptions ''Expected+deriveJSON defaultOptions ''FormatExpected+deriveJSON defaultOptions ''Step+$(SC.deriveSafeCopy 1 'SC.base ''Step)
+ src/Data/API/Markdown.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE RecordWildCards #-}++-- | This module generates Markdown-formatted documentation for an+-- API, like this:+--+-- > ###Foo+-- >+-- > a test defn+-- >+-- > JSON Type : **union object** (Haskell prefix is 'foo')+-- >+-- > | Alternative | Type | Comment+-- > | ----------- | ------- | -----------+-- > | _`Baz`_ | boolean | just a bool+-- > | _`Qux`_ | integer | just an int++module Data.API.Markdown+ ( markdown+ , MarkdownMethods(..)+ , defaultMarkdownMethods+ , thing+ ) where++import Data.API.Types+import Data.API.Utils++import qualified Data.CaseInsensitive as CI+import Data.Char+import Text.Printf+import Control.Applicative+import Control.Lens+++data MarkdownMethods+ = MDM+ { mdmSummaryPostfix :: TypeName -> MDComment+ , mdmLink :: TypeName -> MDComment+ , mdmPp :: MDComment -> MDComment -> MDComment+ , mdmFieldDefault :: FieldName -> APIType -> Maybe DefaultValue+ }++defaultMarkdownMethods :: MarkdownMethods+defaultMarkdownMethods =+ MDM { mdmSummaryPostfix = const ""+ , mdmLink = _TypeName+ , mdmPp = (++)+ , mdmFieldDefault = \ _ _ -> Nothing+ }++-- | Create human-readable API documentation in Markdown format+markdown :: MarkdownMethods -> API -> MDComment+markdown mdm ths = foldr (thing mdm) "" ths++-- | Document a single API comment or node in Markdown format+thing :: MarkdownMethods -> Thing -> MDComment -> MDComment+thing mdm th tl_md =+ case th of+ ThComment md -> mdmPp mdm md tl_md+ ThNode an -> node mdm an tl_md++node :: MarkdownMethods -> APINode -> MDComment -> MDComment+node mdm an tl_md =+ header mdm an $ body mdm an $ version an $ "\n\n" ++ tl_md++header :: MarkdownMethods -> APINode -> MDComment -> MDComment+header mdm an tl_md =+ printf "###%s\n\n%s\n\n%s" nm_md (mdmPp mdm cm_md "") tl_md+ where+ nm_md = type_name_md an+ cm_md = comment_md an++body :: MarkdownMethods -> APINode -> MDComment -> MDComment+body mdm an tl_md =+ case anSpec an of+ SpNewtype sn -> block tl_md $ ntype mdm an sn+ SpRecord sr -> block tl_md $ record mdm an sr+ SpUnion su -> block tl_md $ union_ mdm an su+ SpEnum se -> block tl_md $ enum_ mdm an se+ SpSynonym ty -> block tl_md $ synonym mdm an ty++ntype :: MarkdownMethods -> APINode -> SpecNewtype -> [MDComment]+ntype mdm an sn =+ summary_lines mdm an (basic_type_md $ snType sn) ++ [f ftr | Just ftr<-[snFilter sn]]+ 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++ rg _ Nothing Nothing = "**no restriction**" -- should not happen (not produced by parser)+ rg sh Nothing (Just hi) = "x <= " ++ sh hi+ rg sh (Just lo) Nothing = sh lo ++ " <= x"+ rg sh (Just lo) (Just hi) = sh lo ++ " <= x <= " ++ sh hi++record :: MarkdownMethods -> APINode -> SpecRecord -> [MDComment]+record mdm an sr =+ summary_lines mdm an "record object" ++ mk_md_record_table mdm (srFields sr)++union_ :: MarkdownMethods -> APINode -> SpecUnion -> [MDComment]+union_ mdm an su =+ summary_lines mdm an "union object" ++ mk_md_union_table mdm (suFields su)++enum_ :: MarkdownMethods -> APINode -> SpecEnum -> [MDComment]+enum_ mdm an SpecEnum{..} =+ summary_lines mdm an "string enumeration" ++ map f (hdr : dhs : rws)+ where+ f (fnm,cmt) = ljust lnx fnm ++ " | " ++ cmt++ dhs = (replicate lnx '-',replicate 7 '-')++ lnx = maximum $ 0 : map (length . _FieldName . fst) seAlts++ rws = map fmt seAlts++ hdr = ("Enumeration","Comment")++ fmt (fn0,ct) = (_FieldName fn0,mdmPp mdm "" $ cln ct)++ cln ct = reverse $ dropWhile isSpace $ reverse $ map tr ct+ where+ tr '\n' = ' '+ tr c = c++synonym :: MarkdownMethods -> APINode -> APIType -> [MDComment]+synonym mdm an ty = summary_lines mdm an $ type_md mdm ty++mk_md_record_table :: MarkdownMethods -> [(FieldName, FieldType)] -> [MDComment]+mk_md_record_table mdm fds = map f $ hdr : dhs : rws+ where+ f = if all (null . view _4) rws then f3 else f4++ f3 (x,y,z,_) = ljust lnx x ++ " | " ++ ljust lny y ++ " | " ++ z+ f4 (x,y,z,a) = ljust lnx x ++ " | " ++ ljust lny y ++ " | " ++ ljust lnz z ++ " | " ++ a++ dhs = (replicate lnx '-',replicate lny '-',replicate lnz '-',replicate 7 '-')++ lnx = maximum $ map (length . view _1) $ hdr : rws+ lny = maximum $ map (length . view _2) $ hdr : rws+ lnz = maximum $ map (length . view _3) $ hdr : rws++ hdr = ("Field","Type","Default","Comment")++ rws = map fmt fds++ fmt (fn0,fty) = ( fn, type_md mdm ty, flg_md, mdmPp mdm "" $ cleanComment ct )+ where+ fn = _FieldName fn0+ ty = ftType fty+ ct = ftComment fty++ flg_md | ftReadOnly fty = "*read-only*"+ | otherwise = default_md $ ftDefault fty++ default_md mb_dv = maybe "" (backticks . default_value)+ (mdmFieldDefault mdm fn0 ty <|> mb_dv)+ backticks s = "`" ++ s ++ "`"++mk_md_union_table :: MarkdownMethods ->+ [(FieldName, (APIType, MDComment))] -> [MDComment]+mk_md_union_table mdm fds = map f $ hdr : dhs : rws+ where+ f = if all (null . view _3) rws then f2 else f3++ f2 (x,y,_) = ljust lnx x ++ " | " ++ y+ f3 (x,y,z) = ljust lnx x ++ " | " ++ ljust lny y ++ " | " ++ z++ dhs = (replicate lnx '-',replicate lny '-',replicate 7 '-')++ lnx = maximum $ map (length . view _1) $ hdr : rws+ lny = maximum $ map (length . view _2) $ hdr : rws++ hdr = ("Alternative","Type","Comment")++ rws = map fmt fds++ fmt (fn0,(ty,ct)) = ("_" ++ fn ++ "_",type_md mdm ty,mdmPp mdm "" $ cleanComment ct)+ where+ fn = _FieldName fn0++cleanComment :: MDComment -> MDComment+cleanComment ct = reverse $ dropWhile isSpace $ reverse $ map tr ct+ where+ tr '\n' = ' '+ tr c = c++summary_lines :: MarkdownMethods -> APINode -> String -> [MDComment]+summary_lines mdm an smy =+ [ printf "JSON Type : **%s** [Haskell prefix is `%s`] %s" smy pfx pst+ , ""+ ]+ where+ pfx = prefix_md an+ pst = mdmSummaryPostfix mdm $ anName an++default_value :: DefaultValue -> MDComment+default_value dv =+ case dv of+ DefValList -> "[]"+ DefValMaybe -> "null"+ DefValString t -> show t+ DefValBool b -> map toLower $ show b+ DefValInt i -> show i+ DefValUtc u -> show $ mkUTC_ u++type_md :: MarkdownMethods -> APIType -> MDComment+type_md mdm ty =+ case ty of+ TyList ty' -> "[" ++ type_md mdm ty' ++ "]"+ TyMaybe ty' -> "? " ++ type_md mdm ty'+ TyName nm -> mdmLink mdm nm+ TyBasic bt -> basic_type_md bt+ TyJSON -> "json"++basic_type_md :: BasicType -> MDComment+basic_type_md bt =+ case bt of+ BTstring -> "string"+ BTbinary -> "base64 string"+ BTbool -> "boolean"+ BTint -> "integer"+ BTutc -> "utc"++type_name_md, prefix_md, comment_md :: APINode -> MDComment+type_name_md = _TypeName . anName+prefix_md = CI.original . anPrefix+comment_md = anComment++block :: MDComment -> [MDComment] -> MDComment+block tl_md cmts = unlines cmts ++ tl_md++version :: APINode -> MDComment -> MDComment+version _ tl_md = tl_md++ljust :: Int -> String -> String+ljust fw s = s ++ replicate p ' '+ where+ p = max 0 $ fw - length s++{-+pp :: MarkdownMethods -> MDComment -> MDComment -> MDComment+pp mdm s0 tl_md = pp0 s0+ where+ pp0 [] = tl_md+ pp0 (c:t) =+ case c of+ '{' -> pp1 $ break ('}' ==) t+ _ -> c : pp0 t++ pp1 (nm,[] ) = '{' : nm ++ tl_md+ pp1 (nm,_:t) = mdmLink mdm (TypeName nm) ++ pp0 t+-}
+ src/Data/API/PP.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE FlexibleInstances #-}++-- | A cheap and cheerful pretty-printing library+module Data.API.PP+ ( PP(..)+ , PPLines(..)+ , inFrontOf+ , indent+ ) where++import Data.API.JSON+import Data.API.Types++import qualified Data.Aeson as JS+import qualified Data.Aeson.Encode.Pretty as JS+import qualified Data.ByteString.Lazy.Char8 as BL+import Data.List+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as T+import Data.Version+++class PP t where+ pp :: t -> String++class PPLines t where+ ppLines :: t -> [String]+++inFrontOf :: String -> [String] -> [String]+inFrontOf x [] = [x]+inFrontOf x (s:ss) = (x ++ s) : ss++indent :: [String] -> [String]+indent = map (" " ++)+++instance PP [Char] where+ pp = id++instance PP Version where+ pp = showVersion++instance PP t => PP (Set t) where+ pp s = intercalate ", " (map pp $ Set.toList s)++instance PP T.Text where+ pp = T.unpack++instance PPLines JS.Value where+ ppLines v = lines $ BL.unpack $ JS.encodePretty v++instance PP TypeName where+ pp = _TypeName++instance PP FieldName where+ pp = _FieldName++instance PP APIType where+ pp (TyList ty) = "[" ++ pp ty ++ "]"+ pp (TyMaybe ty) = "? " ++ pp ty+ pp (TyName t) = pp t+ pp (TyBasic b) = pp b+ pp TyJSON = "json"++instance PP BasicType where+ pp BTstring = "string"+ pp BTbinary = "binary"+ pp BTbool = "bool"+ pp BTint = "integer"+ pp BTutc = "utc"++instance PP DefaultValue where+ pp DefValList = "[]"+ pp DefValMaybe = "nothing"+ pp (DefValString t) = show t+ pp (DefValBool True) = "true"+ pp (DefValBool False) = "false"+ pp (DefValInt i) = show i+ pp (DefValUtc u) = show u+++instance PPLines t => PPLines [t] where+ ppLines = concatMap ppLines++instance (PPLines s, PPLines t) => PPLines (s, t) where+ ppLines (s, t) = ppLines s ++ ppLines t++instance PPLines Step where+ ppLines s = [prettyStep s]
+ src/Data/API/Parse.y view
@@ -0,0 +1,368 @@+{+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+++module Data.API.Parse+ ( parseAPI+ , parseAPIWithChangelog+ , api+ , apiWithChangelog+ ) where++import Data.API.Types+import Data.API.Scan+import Data.API.Changes+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.Quote+import Text.Printf+import Text.Regex+}++%name parse API+%name parse_with_changelog APIWithChangelog++%tokentype { PToken }+++%token+ ';' { (,) _ Semi }+ '|' { (,) _ Bar }+ '[' { (,) _ Bra }+ ']' { (,) _ Ket }+ '::' { (,) _ ColCol }+ '=' { (,) _ Equals }+ '?' { (,) _ Query }+ ',' { (,) _ Comma }+ '<=' { (,) _ LtEq }+ '>=' { (,) _ GtEq }+ version { (,) _ Version }+ with { (,) _ With }+ integer { (,) _ Integer }+ boolean { (,) _ Boolean }+ utc { (,) _ UTC }+ string { (,) _ String }+ binary { (,) _ BInary }+ json { (,) _ Json }+ record { (,) _ Record }+ union { (,) _ Union }+ enum { (,) _ Enum }+ basic { (,) _ Basic }+ changes { (,) _ Changes }+ added { (,) _ Added }+ removed { (,) _ Removed }+ renamed { (,) _ Renamed }+ changed { (,) _ Changed }+ default { (,) _ Default }+ field { (,) _ Field }+ alternative { (,) _ Alternative }+ migration { (,) _ Migration }+ to { (,) _ To }+ nothing { (,) _ NOTHING }+ readonly { (,) _ Readonly }+ comment { (,) _ (Comment $$) }+ typeiden { (,) _ (TypeIden $$) }+ variden { (,) _ (VarIden $$) }+ intlit { (,) _ (Intg $$) }+ strlit { (,) _ (Strg $$) }+ true { (,) _ TRUE }+ false { (,) _ FALSE }+ utclit { (,) _ (UTCTIME $$) }+++%%++APIWithChangelog :: { APIWithChangelog }+APIWithChangelog+ : API changes APIChangelog { ($1, $3) }++API :: { API }+API : RAPI { reverse $1 }++RAPI :: { [Thing] }+RAPI+ : RAPI ';' Thing { $3 : $1 }+ | { [] }++Thing :: { Thing }+Thing+ : Node { ThNode $1 }+ | Comments { ThComment $1 }++Node :: { APINode }+Node+ : Prefix '::' typeiden Comments '=' Spec With+ { APINode (TypeName $3) $4 $1 $6 $7 }++Spec :: { Spec }+Spec+ : Record { SpRecord $1 }+ | Union { SpUnion $1 }+ | Enum { SpEnum $1 }+ | Basic { SpNewtype $1 }+ | Type { SpSynonym $1 }++With :: { Conversion }+With+ : with FieldName ',' FieldName { Just ($2,$4) }+ | { Nothing }++Comments :: { MDComment }+Comments+ : RCommentList { unlines $ reverse $1 }++RCommentList :: { [MDComment] }+RCommentList+ : RCommentList comment { $2 : $1 }+ | { [] }++Prefix :: { Prefix }+Prefix+ : VarIdentifier { CI.mk $1 }++Record :: { SpecRecord }+Record+ : record RRFields { SpecRecord $ reverse $2 }++Union :: { SpecUnion }+Union+ : union RUFields { SpecUnion $ reverse $2 }++RRFields :: { [(FieldName, FieldType)] }+RRFields+ : RRFields FieldName '::' FieldType { ($2,$4) : $1 }+ | FieldName '::' FieldType { [($1,$3)] }++FieldType :: { FieldType }+FieldType+ : Type IsReadOnly MayBasicLit Comments+ { FieldType $1 $2 $3 $4 }++IsReadOnly :: { Bool }+ : readonly { True }+ | { False }++RUFields :: { [(FieldName,(APIType,MDComment))] }+RUFields+ : RUFields '|' FieldName '::' Type Comments+ { ($3,($5,$6)) : $1 }+ | '|' FieldName '::' Type Comments+ { [($2,($4,$5))] }++Enum :: { SpecEnum }+Enum+ : enum REnums { SpecEnum $ reverse $2 }++REnums :: { [(FieldName,MDComment)] }+REnums+ : REnums '|' FieldName Comments { ($3,$4) : $1 }+ | '|' FieldName Comments { [($2,$3)] }++Basic :: { SpecNewtype }+ : basic BasicType MbFilter { SpecNewtype $2 $3 }++MbFilter :: { Maybe Filter }+ : '|' Filter { Just $2 }+ | { Nothing }++Filter :: { Filter }+ : RegEx { FtrStrg $1 }+ | '>=' intlit { FtrIntg $ IntRange (Just $2) Nothing }+ | '>=' intlit ',' '<=' intlit { FtrIntg $ IntRange (Just $2) (Just $5) }+ | '<=' intlit { FtrIntg $ IntRange Nothing (Just $2) }+ | '>=' utclit { FtrUTC $ UTCRange (Just $2) Nothing }+ | '>=' utclit ',' '<=' utclit { FtrUTC $ UTCRange (Just $2) (Just $5) }+ | '<=' utclit { FtrUTC $ UTCRange Nothing (Just $2) }++RegEx :: { RegEx }+ : strlit { RegEx (T.pack $1) $ mkRegexWithOpts $1 False True }++Type :: { APIType }+Type+ : '?' Type { TyMaybe $2 }+ | '[' Type ']' { TyList $2 }+ | typeiden { TyName (TypeName $1) }+ | BasicType { TyBasic $1 }+ | json { TyJSON }++MayBasicLit :: { Maybe DefaultValue }+ : DefaultValue { Just $1 }+ | { Nothing }++BasicType :: { BasicType }+BasicType+ : string { BTstring }+ | binary { BTbinary }+ | boolean { BTbool }+ | integer { BTint }+ | utc { BTutc }++FieldName :: { FieldName }+FieldName+ : VarIdentifier { FieldName $1 }++VarIdentifier :: { String }+ : variden { $1 }+ | default { "default" }+ | field { "field" }+ | alternative { "alternative" }+ | to { "to" }++TypeName :: { TypeName }+ : typeiden { TypeName $1 }++APIChangelog :: { APIChangelog }+APIChangelog+ : version VersionExtra Changes ';' APIChangelog { ChangesUpTo $2 $3 $5 }+ | version Version { ChangesStart $2 }+ | Comments ';' APIChangelog { $3 }++Version :: { V.Version }+ : strlit { parseVer $1 }++VersionExtra :: { VersionExtra }+ : strlit { parseVersionExtra $1 }++Changes :: { [APIChange] }+ : RChanges { concat (reverse $1) }++RChanges :: { [[APIChange]] }+ : RChanges Change { $2 : $1 }+ | { [] }++Change :: { [APIChange] }+ : added TypeName Spec { [ChAddType $2 (declNF $3)] }+ | removed TypeName { [ChDeleteType $2] }+ | renamed TypeName to TypeName { [ChRenameType $2 $4] }+ | changed record TypeName RFieldChanges { map (fldChangeToAPIChange $3) (reverse $4) }+ | changed union TypeName RUnionChanges { map (unionChangeToAPIChange $3) (reverse $4) }+ | changed enum TypeName REnumChanges { map (enumChangeToAPIChange $3) (reverse $4) }+ | migration record TypeName MigrationTag { [ChCustomRecord $3 $4] }+ | migration MigrationTag { [ChCustomAll $2] }+ | comment { [] }++RFieldChanges :: { [FieldChange] }+ : RFieldChanges FieldChange { $2 ++ $1 }+ | FieldChange { $1 }++FieldChange :: { [FieldChange] }+ : field added FieldName '::' Type MbDefaultValue { [FldChAdd $3 $5 $6] }+ | field removed FieldName { [FldChDelete $3] }+ | field renamed FieldName to FieldName { [FldChRename $3 $5] }+ | field changed FieldName '::' Type migration MigrationTag { [FldChChange $3 $5 $7] }+ | comment { [] }++MbDefaultValue :: { Maybe DefaultValue }+ : default DefaultValue { Just $2 }+ | { Nothing }++DefaultValue :: { DefaultValue }+ : '[' ']' { DefValList }+ | nothing { DefValMaybe }+ | strlit { DefValString (T.pack $1) }+ | true { DefValBool True }+ | false { DefValBool False }+ | intlit { DefValInt $1 }+ | utclit { DefValUtc $1 }++RUnionChanges :: { [UnionChange] }+ : RUnionChanges UnionChange { $2 ++ $1 }+ | UnionChange { $1 }++UnionChange :: { [UnionChange] }+ : alternative added FieldName '::' Type { [UnChAdd $3 $5] }+ | alternative removed FieldName { [UnChDelete $3] }+ | alternative renamed FieldName to FieldName { [UnChRename $3 $5] }+ | comment { [] }++REnumChanges :: { [EnumChange] }+ : REnumChanges EnumChange { $2 ++ $1 }+ | EnumChange { $1 }++EnumChange :: { [EnumChange] }+ : alternative added FieldName { [EnChAdd $3] }+ | alternative removed FieldName { [EnChDelete $3] }+ | alternative renamed FieldName to FieldName { [EnChRename $3 $5] }+ | comment { [] }++MigrationTag :: { MigrationTag }+ : typeiden { $1 }++{+happyError :: [PToken] -> a+happyError tks = error $ printf "Syntax error at %s: %s\n" loc $ show (take 5 tks)+ where+ loc = case tks of+ [] -> "<EOF>"+ (AlexPn ad ln cn,_):_ -> printf "line %d, column %d (@%d)" ln cn ad++parseAPI :: String -> API+parseAPI = parse . scan++parseAPIWithChangelog :: String -> APIWithChangelog+parseAPIWithChangelog = parse_with_changelog . scan+++data FieldChange = FldChAdd FieldName APIType (Maybe DefaultValue)+ | FldChDelete FieldName+ | FldChRename FieldName FieldName+ | FldChChange FieldName APIType MigrationTag++fldChangeToAPIChange :: TypeName -> FieldChange -> APIChange+fldChangeToAPIChange t (FldChAdd f ty def) = ChAddField t f ty def+fldChangeToAPIChange t (FldChDelete f) = ChDeleteField t f+fldChangeToAPIChange t (FldChRename f f') = ChRenameField t f f'+fldChangeToAPIChange t (FldChChange f ty m) = ChChangeField t f ty m++data UnionChange = UnChAdd FieldName APIType+ | UnChDelete FieldName+ | UnChRename FieldName FieldName++unionChangeToAPIChange :: TypeName -> UnionChange -> APIChange+unionChangeToAPIChange t (UnChAdd f ty) = ChAddUnionAlt t f ty+unionChangeToAPIChange t (UnChDelete f) = ChDeleteUnionAlt t f+unionChangeToAPIChange t (UnChRename f f') = ChRenameUnionAlt t f f'++data EnumChange = EnChAdd FieldName+ | EnChDelete FieldName+ | EnChRename FieldName FieldName++enumChangeToAPIChange :: TypeName -> EnumChange -> APIChange+enumChangeToAPIChange t (EnChAdd f) = ChAddEnumVal t f+enumChangeToAPIChange t (EnChDelete f) = ChDeleteEnumVal t f+enumChangeToAPIChange t (EnChRename f f') = ChRenameEnumVal t f f'+++parseVer :: String -> V.Version+parseVer x = case simpleParse x of+ Just v -> v+ Nothing -> error $ "Syntax error while parsing version " ++ x++parseVersionExtra :: String -> VersionExtra+parseVersionExtra "development" = DevVersion+parseVersionExtra s = Release $ parseVer s+++api :: QuasiQuoter+api =+ QuasiQuoter+ { quoteExp = \s -> [| parseAPI s |]+ , quotePat = error "api QuasiQuoter used in patten context"+ , quoteType = error "api QuasiQuoter used in type context"+ , quoteDec = error "api QuasiQuoter used in declaration context"+ }++apiWithChangelog :: QuasiQuoter+apiWithChangelog =+ QuasiQuoter+ { quoteExp = \s -> [| parseAPIWithChangelog s |]+ , quotePat = error "apiWithChangelog QuasiQuoter used in patten context"+ , quoteType = error "apiWithChangelog QuasiQuoter used in type context"+ , quoteDec = error "apiWithChangelog QuasiQuoter used in declaration context"+ }+}
+ src/Data/API/Scan.x view
@@ -0,0 +1,192 @@+{+{-# OPTIONS_GHC -w #-}++module Data.API.Scan+ ( scan+ , PToken+ , AlexPosn(..)+ , Token(..)+ ) where++import Data.API.Types+import Data.API.Utils++import Data.Char+import Data.Time+import Safe+}++%wrapper "posn"++$digit = 0-9 -- digits+$lower = [a-z_] -- lower case & _+$upper = [A-Z] -- upper case letters++@d2 = $digit{2}+@d4 = $digit{4}+++tokens :-+ $white+ ;+ "--".* ;+ "{-"(\n|[^\-]|\-[^\}])*"-}" ;+ ";" { simple Semi }+ "|" { simple Bar }+ "[" { simple Bra }+ "]" { simple Ket }+ "::" { simple ColCol }+ ":" { simple Colon }+ "=" { simple Equals }+ "<=" { simple LtEq }+ ">=" { simple GtEq }+ "?" { simple Query }+ "," { simple Comma }+ version { simple Version }+ with { simple With } + integer { simple Integer }+ boolean { simple Boolean }+ utc { simple UTC }+ string { simple String }+ binary { simple BInary }+ json { simple Json }+ record { simple Record }+ union { simple Union }+ enum { simple Enum }+ basic { simple Basic }+ changes { simple Changes }+ added { simple Added }+ removed { simple Removed }+ renamed { simple Renamed }+ changed { simple Changed }+ default { simple Default }+ field { simple Field }+ alternative { simple Alternative }+ migration { simple Migration }+ to { simple To }+ nothing { simple NOTHING }+ true { simple TRUE }+ false { simple FALSE }+ read\-only { simple Readonly }+ @d4\-@d2\-(@d2)T@d2\:@d2(:@d2)?Z { utc_ }+ $upper [$lower $upper $digit]* { mk TypeIden }+ \'$upper [$lower $upper $digit]*\' { strip_qs TypeIden }+ $lower [$lower $upper $digit]* { mk VarIden }+ \'$lower [$lower $upper $digit]*\' { strip_qs VarIden }+ \"([^\\\"]|\\[\\\'\"])*\" { string }+ \-?$digit+ { intg }+ "//".* { line_comment }+ "(*"(\n|[^\*]|\*[^\)])*"*)" { block_comment }++{++type PToken = (AlexPosn,Token)++data Token+ = Semi+ | Bar+ | BInary+ | Bra+ | Ket+ | ColCol+ | Colon+ | Comma+ | Equals+ | LtEq+ | GtEq+ | Boolean+ | Integer+ | UTC+ | Query+ | Record+ | String+ | Json+ | Union+ | Version+ | With+ | Enum+ | Basic+ | Changes+ | Added+ | Removed+ | Renamed+ | Changed+ | Default+ | Field+ | Alternative+ | Migration+ | To+ | NOTHING+ | TRUE+ | FALSE+ | Readonly+ | UTCTIME UTCTime+ | Comment String+ | TypeIden String+ | VarIden String+ | Intg Int+ | Strg String+ | ERROR+ deriving (Eq,Show)++utc_ :: AlexPosn -> String -> PToken+utc_ = mk $ \s -> maybe ERROR UTCTIME $ parseUTC_ s++line_comment :: AlexPosn -> String -> PToken+line_comment = mk $ Comment . munch_ws . tailSafe . tailSafe ++block_comment :: AlexPosn -> String -> PToken+block_comment p (_:_:str) = + case reverse $ munch_ws str of+ _:_:rc -> (p,Comment $ reverse $ munch_ws rc)+ _ -> error "Scan.line_comment"+block_comment _ _ = error "Scan.line_comment" ++strip_qs :: (String->Token) -> AlexPosn -> String -> PToken+strip_qs f p (_:s) = (p,f $ initNote "Scan.strip_qs" s)+strip_qs _ _ _ = error "Scan.strip_qs"++munch_ws :: String -> String+munch_ws = dropWhile isSpace++simple :: Token -> AlexPosn -> String -> PToken+simple tk = mk $ const tk++intg :: AlexPosn -> String -> PToken+intg p s = (p,Intg $ readNote "Data.API.Scan.intg" s)++string :: AlexPosn -> String -> PToken+string = mk (Strg . f . chop)+ where+ f "" = ""+ f (c:s) = case c of+ '\\' -> g s+ _ -> c : f s++ g "" = ""+ g (c:s) = c : f s++chop :: String -> String+chop "" = ""+chop (c:s) =+ case reverse s of+ "" -> ""+ _:rs -> reverse rs++mk :: (String->Token) -> AlexPosn -> String -> PToken+mk f p s = (p,f s)++scan :: String -> [PToken]+scan = pp . alexScanTokens++pp :: [PToken] -> [PToken]+pp [] = []+pp (pt@(p@(AlexPn _ _ cn),_):inp) =+ case cn of+ 1 -> (p,Semi):pt:pp inp+ _ -> pt:pp inp++test :: IO ()+test = + do s <- getContents+ print (scan s)+}
+ src/Data/API/TH.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.API.TH+ ( applicativeE+ , optionalInstanceD+ , funSigD+ , simpleD+ , simpleSigD+ ) where++import Data.API.Tools.Combinators++import Control.Applicative+import Control.Monad+import Language.Haskell.TH+++-- | Construct an idiomatic expression (an expression in an+-- Applicative context), i.e.+-- app ke [] => ke+-- app ke [e1,e2,...,en] => ke <$> e1 <*> e2 ... <*> en+applicativeE :: ExpQ -> [ExpQ] -> ExpQ+applicativeE ke es0 =+ case es0 of+ [] -> ke+ e:es -> app' (ke `dl` e) es+ where+ app' e [] = e+ app' e (e':es) = app' (e `st` e') es++ st e1 e2 = appE (appE (varE '(<*>)) e1) e2+ dl e1 e2 = appE (appE (varE '(<$>)) e1) e2+++-- | Add an instance declaration for a class, if such an instance does+-- not already exist+optionalInstanceD :: ToolSettings -> Name -> [TypeQ] -> [DecQ] -> Q [Dec]+optionalInstanceD stgs c tqs dqs = do+ ts <- sequence tqs+ ds <- sequence dqs+ exists <- isInstance c ts+ if exists then do when (warnOnOmittedInstance stgs) $ reportWarning $ msg ts+ return []+ else return [InstanceD [] (foldl AppT (ConT c) ts) ds]+ where+ msg ts = "instance " ++ pprint c ++ " " ++ pprint ts ++ " already exists, so it was not generated"+++-- | Construct a TH function with a type signature+funSigD :: Name -> TypeQ -> [ClauseQ] -> Q [Dec]+funSigD n t cs = (\ x y -> [x,y]) <$> sigD n t <*> funD n cs++-- | Construct a simple TH definition+simpleD :: Name -> ExpQ -> Q Dec+simpleD n e = funD n [clause [] (normalB e) []]++-- | Construct a simple TH definition with a type signature+simpleSigD :: Name -> TypeQ -> ExpQ -> Q [Dec]+simpleSigD n t e = funSigD n t [clause [] (normalB e) []]
+ src/Data/API/Tools.hs view
@@ -0,0 +1,62 @@+-- | This module provides an interface for generating TH declarations+-- from an 'API'. To use it, splice in a call to 'generate' followed+-- by one or more calls to 'generateAPITools', like so:+--+-- > $(generate myAPI)+-- > $(generateAPITools [enumTool, jsonTool, quickCheckTool] myAPI)+--+-- If you wish to override any of the instances generated by the+-- tools, you can do so by writing instance declarations after the+-- call to 'generate' but before the call to 'generateAPITools'.++module Data.API.Tools+ ( generate+ , generateAPITools++ -- * Tool settings+ , generateAPIToolsWith+ , defaultToolSettings+ , warnOnOmittedInstance++ -- * Individual tools+ , enumTool+ , exampleTool+ , jsonTool+ , jsonTestsTool+ , lensTool+ , quickCheckTool+ , safeCopyTool+ , samplesTool+ ) where++import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.Tools.Enum+import Data.API.Tools.Example+import Data.API.Tools.JSON+import Data.API.Tools.JSONTests+import Data.API.Tools.Lens+import Data.API.Tools.QuickCheck+import Data.API.Tools.SafeCopy+import Data.API.Types++import Data.Monoid+import Language.Haskell.TH+++-- | Generate the datatypes corresponding to an API.+generate :: API -> Q [Dec]+generate api = generateAPITools api [datatypesTool]++-- | Apply a list of tools to an 'API', generating TH declarations.+-- See the individual tool descriptions for details. Note that+-- 'generate' must be called first, and some tools have dependencies,+-- which must be included in the same or a preceding call to+-- 'generateAPITools'.+generateAPITools :: API -> [APITool] -> Q [Dec]+generateAPITools = generateAPIToolsWith defaultToolSettings++-- | Apply a list of tools to an 'API', generating TH declarations.+-- This form allows the 'ToolSettings' to be overridden.+generateAPIToolsWith :: ToolSettings -> API -> [APITool] -> Q [Dec]+generateAPIToolsWith ts api tools = runTool (mconcat tools) ts api
+ src/Data/API/Tools/Combinators.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.API.Tools.Combinators+ ( Tool+ , APITool+ , APINodeTool+ , runTool++ -- * Smart constructors and combinators+ , simpleTool+ , mkTool+ , contramapTool+ , subTools+ , apiNodeTool+ , apiDataTypeTool+ , apiSpecTool++ -- * Tool settings+ , ToolSettings+ , warnOnOmittedInstance+ , defaultToolSettings+ ) where++import Data.API.Types++import Control.Applicative+import Data.Monoid+import Language.Haskell.TH+++-- | Settings to control the behaviour of API tools. This record may+-- be extended in the future, so you should construct a value by+-- overriding individual fields of 'defaultToolSettings'.+data ToolSettings = ToolSettings+ { warnOnOmittedInstance :: Bool+ -- ^ Generate a warning when an instance declaration is omitted+ -- because it already exists+ }++-- | Default settings designed to be overridden.+defaultToolSettings :: ToolSettings+defaultToolSettings = ToolSettings+ { warnOnOmittedInstance = False+ }++-- | A @'Tool' a@ is something that can generate TH declarations from+-- a value of type @a@. Tools can be combined using the 'Monoid'+-- instance.+newtype Tool a = Tool+ { runTool :: ToolSettings -> a -> Q [Dec]+ -- ^ Execute a tool to generate some TH declarations.+ }++type APITool = Tool API+type APINodeTool = Tool APINode++instance Monoid (Tool a) where+ mempty = Tool $ \ _ _ -> return []+ Tool t1 `mappend` Tool t2 = Tool $ \ ts x -> (++) <$> t1 ts x <*> t2 ts x++-- | Construct a tool that does not depend on any settings+simpleTool :: (a -> Q [Dec]) -> Tool a+simpleTool f = Tool $ const f++-- | Construct a tool that may depend on the settings+mkTool :: (ToolSettings -> a -> Q [Dec]) -> Tool a+mkTool = Tool++-- | 'Tool' is a contravariant functor+contramapTool :: (a -> b) -> Tool b -> Tool a+contramapTool f t = Tool $ \ ts a -> runTool t ts (f a)++-- | Apply a tool that acts on elements of a list to the entire list+subTools :: Tool a -> Tool [a]+subTools t = Tool $ \ ts as -> concat <$> mapM (runTool t ts) as++-- | Apply a tool that acts on nodes to an entire API+apiNodeTool :: Tool APINode -> Tool API+apiNodeTool = contramapTool (\ api -> [an | ThNode an <- api ]) . subTools++-- | Apply a tool that acts on datatype nodes (i.e. those that are not+-- synonyms) to an entire API+apiDataTypeTool :: Tool APINode -> Tool API+apiDataTypeTool = contramapTool (\ api -> [an | ThNode an <- api, hasDataType $ anSpec an ]) . subTools+ where+ hasDataType (SpSynonym _) = False+ hasDataType _ = True++-- | Create a tool that acts on nodes from its action on individual+-- specs.+apiSpecTool :: Tool (APINode, SpecNewtype)+ -> Tool (APINode, SpecRecord )+ -> Tool (APINode, SpecUnion )+ -> Tool (APINode, SpecEnum )+ -> Tool (APINode, APIType )+ -> Tool APINode+apiSpecTool n r u e s = Tool $ \ ts an -> case anSpec an of+ SpNewtype sn -> runTool n ts (an, sn)+ SpRecord sr -> runTool r ts (an, sr)+ SpUnion su -> runTool u ts (an, su)+ SpEnum se -> runTool e ts (an, se)+ SpSynonym ss -> runTool s ts (an, ss)
+ src/Data/API/Tools/Datatypes.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.API.Tools.Datatypes+ ( datatypesTool+ , type_nm+ , rep_type_nm+ , nodeT+ , nodeRepT+ , nodeConE+ , nodeFieldE+ , nodeAltConE+ , nodeAltConP+ , newtypeProjectionE+ ) where++import Data.API.Tools.Combinators+import Data.API.Types++import Data.Aeson+import qualified Data.CaseInsensitive as CI+import Data.Char+import Data.String+import qualified Data.Text as T+import Data.Time+import Data.Typeable+import Language.Haskell.TH+++-- | Tool to generate datatypes and type synonyms corresponding to an API+datatypesTool :: APITool+datatypesTool = apiNodeTool $ apiSpecTool (simpleTool $ uncurry gen_sn_dt)+ (simpleTool $ uncurry gen_sr_dt)+ (simpleTool $ uncurry gen_su_dt)+ (simpleTool $ uncurry gen_se_dt)+ (simpleTool $ uncurry gen_sy)+++-- | Generate a type synonym definition+gen_sy :: APINode -> APIType -> Q [Dec]+gen_sy as ty = return [TySynD (type_nm as) [] $ mk_type ty]+++-- | Generate a newtype definition, like this:+--+-- > newtype JobId = JobId { _JobId :: T.Text }+-- > deriving (Show,IsString,Eq,Typeable)++gen_sn_dt :: APINode -> SpecNewtype -> Q [Dec]+gen_sn_dt as sn = return [NewtypeD [] nm [] c $ derive_leaf_nms ++ iss]+ where+ c = RecC nm [(newtype_prj_nm as,NotStrict,mk_type $ TyBasic (snType sn))]++ nm = rep_type_nm as++ iss = case snType sn of+ BTstring -> [''IsString]+ BTbinary -> []+ BTbool -> []+ BTint -> []+ BTutc -> []++++-- | Generate a record type definition, like this:+--+-- > data JobSpecId+-- > = JobSpecId+-- > { _jsi_id :: JobId+-- > , _jsi_input :: JSInput+-- > , _jsi_output :: JSOutputStatus+-- > , _jsi_pipelineId :: PipelineId+-- > }+-- > deriving (Show,Eq,Typeable)++gen_sr_dt :: APINode -> SpecRecord -> Q [Dec]+gen_sr_dt as sr = return [DataD [] nm [] cs derive_node_nms] -- [show_nm,eq_nm]+ where+ cs = [RecC nm [(pref_field_nm as fnm,IsStrict,mk_type (ftType fty)) |+ (fnm,fty)<-srFields sr]]++ nm = rep_type_nm as+++-- | Generate a union type definition, like this:+--+-- > data Foo = F_Bar Int | F_Baz Bool+-- > deriving (Show,Typeable)++gen_su_dt :: APINode -> SpecUnion -> Q [Dec]+gen_su_dt as su = return [DataD [] nm [] cs derive_node_nms] -- [show_nm,eq_nm]+ where+ cs = [NormalC (pref_con_nm as fnm) [(IsStrict,mk_type ty)] |+ (fnm,(ty,_))<-suFields su]++ nm = rep_type_nm as+++-- | Generate an enum type definition, like this:+--+-- > data FrameRate+-- > = FR_auto+-- > | FR_10+-- > | FR_15+-- > | FR_23_97+-- > | FR_24+-- > | FR_25+-- > | FR_29_97+-- > | FR_30+-- > | FR_60+-- > deriving (Show,Eq,Ord,Bounded,Enum,Typeable)++gen_se_dt :: APINode -> SpecEnum -> Q [Dec]+gen_se_dt as se = return [DataD [] nm [] cs $ derive_leaf_nms ++ [''Bounded, ''Enum]]+ where+ cs = [NormalC (pref_con_nm as fnm) [] | (fnm,_) <- seAlts se ]++ nm = rep_type_nm as+++mk_type :: APIType -> Type+mk_type ty =+ case ty of+ TyList ty' -> AppT ListT $ mk_type ty'+ TyMaybe ty' -> AppT (ConT ''Maybe) $ mk_type ty'+ TyName nm -> ConT $ mkName $ _TypeName nm+ TyBasic bt -> basic_type bt+ TyJSON -> ConT ''Value++basic_type :: BasicType -> Type+basic_type bt =+ case bt of+ BTstring -> ConT ''T.Text+ BTbinary -> ConT ''Binary+ BTbool -> ConT ''Bool+ BTint -> ConT ''Int+ BTutc -> ConT ''UTCTime+++derive_leaf_nms :: [Name]+derive_leaf_nms = [''Show,''Eq,''Ord,''Typeable]++derive_node_nms :: [Name]+derive_node_nms = [''Show,''Eq,''Typeable]+++-- | Name of the type corresponding to the API node, e.g. @JobId@+type_nm :: APINode -> Name+type_nm an = mkName $ _TypeName $ anName an++-- | Name of the representation type corresponding to the API node,+-- which differs from the 'type_nm' only if custom conversion+-- functions are specified. This is also the name of the sole+-- constructor for newtypes and records.+rep_type_nm :: APINode -> Name+rep_type_nm an = mkName $ rep_type_s an++-- | Name of the single field in a newtype, prefixed by an underscore,+-- e.g. @_JobId@+newtype_prj_nm :: APINode -> Name+newtype_prj_nm an = mkName $ "_" ++ rep_type_s an++rep_type_s :: APINode -> String+rep_type_s an = f $ _TypeName $ anName an+ where+ f s = maybe s (const ("REP__"++s)) $ anConvert an++-- | Construct the name of a record field by attaching the+-- type-specific prefix, in lowercase, e.g. @_jsi_id@+pref_field_nm :: APINode -> FieldName -> Name+pref_field_nm as fnm = mkName $ pre ++ _FieldName fnm+ where+ pre = "_" ++ map toLower (CI.original $ anPrefix as) ++ "_"++-- | Construct the name of a union or enum constructor by attaching+-- the type-specific prefix, in uppercase, e.g. @FR_auto@+pref_con_nm :: APINode -> FieldName -> Name+pref_con_nm as fnm = mkName $ pre ++ _FieldName fnm+ where+ pre = map toUpper (CI.original $ anPrefix as) ++ "_"+++-- | The type corresponding to an API node+nodeT :: APINode -> TypeQ+nodeT = conT . type_nm++-- | The representation type corresponding to an API node+nodeRepT :: APINode -> TypeQ+nodeRepT = conT . rep_type_nm++-- | The constructor for a newtype or record API node+nodeConE :: APINode -> ExpQ+nodeConE = conE . rep_type_nm++-- | A record field in an API node, as an expression+nodeFieldE :: APINode -> FieldName -> ExpQ+nodeFieldE an fnm = varE $ pref_field_nm an fnm++-- | A prefixed constructor for a union or enum, as an expression+nodeAltConE :: APINode -> FieldName -> ExpQ+nodeAltConE an fn = conE $ pref_con_nm an fn++-- | A prefixed constructor for a union or enum, as a pattern+nodeAltConP :: APINode -> FieldName -> [PatQ] -> PatQ+nodeAltConP an fn = conP (pref_con_nm an fn)++-- | The projection function from a newtype API node, as an epxression+newtypeProjectionE :: APINode -> ExpQ+newtypeProjectionE = varE . newtype_prj_nm
+ src/Data/API/Tools/Enum.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE TemplateHaskell #-}++-- | A tool to generate maps to and from 'Text' values corresponding+-- to inhabitants of enumerated types+module Data.API.Tools.Enum+ ( enumTool+ , text_enum_nm+ , map_enum_nm+ ) where++import Data.API.TH+import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.Types++import qualified Data.Text as T+import qualified Data.Map as Map+import Data.Monoid+import Language.Haskell.TH+++-- | Tool to generate the maps between enumerations and 'Text' strings+-- named by 'text_enum_nm' and 'map_enum_nm'.+enumTool :: APITool+enumTool = apiNodeTool $ apiSpecTool mempty mempty mempty enum mempty+ where+ enum = simpleTool (uncurry gen_se_tx) <> simpleTool (gen_se_mp . fst)+++-- | For an enum type @E@, name a function @_text_E :: E -> 'Text'@+-- that gives a string corresponding to the inhabitant of the type.+-- For example, we generate something like this:+--+-- > _text_FrameRate :: FrameRate -> T.Text+-- > _text_FrameRate fr =+-- > case fr of+-- > FRauto -> "auto"+-- > FR10 -> "10"+-- > FR15 -> "15"+-- > FR23_97 -> "23.97"+-- > FR24 -> "24"+-- > FR25 -> "25"+-- > FR29_97 -> "29.97"+-- > FR30 -> "30"+-- > FR60 -> "60"++text_enum_nm :: APINode -> Name+text_enum_nm an = mkName $ "_text_" ++ (_TypeName $ anName an)++gen_se_tx :: APINode -> SpecEnum -> Q [Dec]+gen_se_tx as se = simpleSigD (text_enum_nm as)+ [t| $tc -> T.Text |]+ bdy+ where+ tc = conT $ rep_type_nm as++ bdy = lamCaseE [ match (pt fnm) (bd fnm) []+ | (fnm,_) <- seAlts se ]++ pt fnm = nodeAltConP as fnm []++ bd fnm = normalB $ stringE $ _FieldName fnm++++-- | For an enum type @E@, name a map from 'Text' values to+-- inhabitants of the type, for example:+--+-- > _map_FrameRate :: Map Text FrameRate+-- > _map_FrameRate = genTextMap _text_FrameRate++map_enum_nm :: APINode -> Name+map_enum_nm an = mkName $ "_map_" ++ (_TypeName $ anName an)++gen_se_mp :: APINode -> Q [Dec]+gen_se_mp as = simpleSigD (map_enum_nm as)+ [t| Map.Map T.Text $tc |]+ [e| genTextMap $(varE $ text_enum_nm as) |]+ where+ tc = conT $ rep_type_nm as++genTextMap :: (Ord a,Bounded a,Enum a) => (a->T.Text) -> Map.Map T.Text a+genTextMap f = Map.fromList [ (f x,x) | x<-[minBound..maxBound] ]
+ src/Data/API/Tools/Example.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Tool for generating documentation-friendly examples+module Data.API.Tools.Example+ ( Example(..)+ , exampleTool+ , samplesTool+ ) where++import Data.API.TH+import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.Types+import Data.API.Utils++import Control.Applicative+import Data.Aeson+import qualified Data.ByteString.Char8 as B+import Data.Monoid+import Data.Time+import Language.Haskell.TH+import Safe+import Test.QuickCheck as QC+import qualified Data.Text as T+++-- | The Example class is used to generate a documentation-friendly+-- example for each type in the model++class Example a where+ -- | Generator for example values; defaults to 'arbitrary' if not+ -- specified+ example :: Gen a+ default example :: Arbitrary a => Gen a+ example = arbitrary++instance Example a => Example (Maybe a) where+ example = oneof [return Nothing, Just <$> example]++instance Example a => Example [a] where+ example = listOf example++instance Example Int where+ example = arbitrarySizedBoundedIntegral `suchThat` (> 0)++instance Example Bool where+ example = choose (False, True)++instance Example T.Text where+ example = return "Mary had a little lamb"++instance Example Binary where+ example = return $ Binary $ B.pack "lots of 1s and 0s"++instance Example Value where+ 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"+++-- | Generate a list of (type name, sample generator) pairs+-- corresponding to each type in the API, with samples encoded as+-- JSON. This depends on the 'Example' instances generated by+-- 'exampleTool'. It generates something like this:+--+-- > samples :: [(String, Gen Value)]+-- > samples = [("Foo", fmap toJSON (example :: Gen Foo)), ... ]++samplesTool :: Name -> APITool+samplesTool nm = simpleTool $ \ api ->+ simpleSigD nm [t| [(String, Gen Value)] |]+ (listE [ gen_sample nd | ThNode nd <- api ])+ where+ gen_sample :: APINode -> ExpQ+ gen_sample an = [e| ($str, fmap toJSON (example :: Gen $(nodeT an))) |]+ where+ str = stringE $ _TypeName $ anName an+++-- | Tool to generate 'Example' instances for types generated by+-- 'datatypesTool'. This depends on 'quickCheckTool'.+exampleTool :: APITool+exampleTool = apiNodeTool $ apiSpecTool gen_sn_ex gen_sr_ex gen_su_ex gen_se_ex mempty+++-- | Generate an 'Example' instance for a newtype. If there is no+-- filter, call 'example' on the underlying type; otherwise, use+-- 'arbitrary'. Like 'Arbitrary', if a regular expression filter is+-- applied the instance must be defined manually.+gen_sn_ex :: Tool (APINode, SpecNewtype)+gen_sn_ex = mkTool $ \ ts (an, sn) -> case snFilter sn of+ Just (FtrStrg _) -> return []+ Just _ -> inst ts an [e| QC.arbitrary |]+ Nothing -> inst ts an [e| fmap $(nodeConE an) example |]+ where+ inst ts an e = optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example e]+++-- | Generate an 'Example' instance for a record:+--+-- > instance Example Foo where+-- > example = sized $ \ x -> Foo <$> resize (x `div` 2) example <*> ... <*> resize (x `div` 2) example++gen_sr_ex :: Tool (APINode, SpecRecord)+gen_sr_ex = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example (bdy an sr)]+ where+ bdy an sr = do x <- newName "x"+ appE (varE 'QC.sized) $ lamE [varP x] $+ applicativeE (nodeConE an) $+ replicate (length $ srFields sr) $+ [e| QC.resize ($(varE x) `div` 2) example |]+++-- | Generate an 'Example' instance for a union:+--+-- > instance Example Foo where+-- > example = oneOf [ fmap Bar example, fmap Baz example ]++gen_su_ex :: Tool (APINode, SpecUnion)+gen_su_ex = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''Example [nodeRepT an] [simpleD 'example (bdy an su)]+ where+ bdy an su | null (suFields su) = nodeConE an+ | otherwise = [e| oneof $(listE (alts an su)) |]++ alts an su = [ [e| fmap $(nodeAltConE an k) example |]+ | (k,_) <- suFields su ]+++-- | Generate an 'Example' instance for an enumeration, with no+-- definition for the 'example' method, because we can inherit the+-- behaviour of 'Arbitrary':+--+-- > instance Example Foo++gen_se_ex :: Tool (APINode, SpecEnum)+gen_se_ex = mkTool $ \ ts (an, _) -> optionalInstanceD ts ''Example [nodeRepT an] []
+ src/Data/API/Tools/JSON.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE TemplateHaskell #-}++module Data.API.Tools.JSON+ ( jsonTool+ , toJsonNodeTool+ , fromJsonNodeTool+ ) where++import Data.API.JSON+import Data.API.TH+import Data.API.Tools.Combinators+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+import qualified Data.Map as Map+import Data.Monoid+import qualified Data.Text as T+import Language.Haskell.TH+++-- | Tool to generate 'ToJSON' and 'FromJSONWithErrs' instances for+-- types generated by 'datatypesTool'. This depends on 'enumTool'.+jsonTool :: APITool+jsonTool = apiNodeTool $ toJsonNodeTool <> fromJsonNodeTool+++-- | Tool to generate 'ToJSON' instance for an API node+toJsonNodeTool :: APINodeTool+toJsonNodeTool = apiSpecTool gen_sn_to gen_sr_to gen_su_to gen_se_to mempty+ <> gen_pr++-- | Tool to generate 'FromJSONWithErrs' instance for an API node+fromJsonNodeTool :: APINodeTool+fromJsonNodeTool = apiSpecTool gen_sn_fm gen_sr_fm gen_su_fm gen_se_fm mempty+ <> gen_in+++{-+instance ToJSON JobId where+ toJSON = String . _JobId+-}++gen_sn_to :: Tool (APINode, SpecNewtype)+gen_sn_to = mkTool $ \ ts (an, sn) -> optionalInstanceD ts ''ToJSON [nodeRepT an]+ [simpleD 'toJSON (bdy an sn)]+ where+ bdy an sn = [e| $(ine sn) . $(newtypeProjectionE an) |]++ ine sn = case snType sn of+ BTstring -> [e| String |]+ BTbinary -> [e| toJSON |]+ BTbool -> [e| Bool |]+ BTint -> [e| mkInt |]+ BTutc -> [e| mkUTC |]+++{-+instance FromJSONWithErrs JobId where+ parseJSONWithErrs = withText "JobId" (pure . JobId)+-}++gen_sn_fm :: Tool (APINode, SpecNewtype)+gen_sn_fm = mkTool $ \ ts (an, sn) -> optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]+ [simpleD 'parseJSONWithErrs (bdy an sn)]+ where+ bdy an sn = [e| $(wth sn) $(typeNameE (anName an)) (pure . $(nodeConE an)) |]++ wth sn =+ case (snType sn, snFilter sn) of+ (BTstring, Just (FtrStrg re)) -> [e| withRegEx re |]+ (BTstring, _ ) -> [e| withText |]+ (BTbinary, _ ) -> [e| withBinary |]+ (BTbool , _ ) -> [e| withBool |]+ (BTint , Just (FtrIntg ir)) -> [e| withIntRange ir |]+ (BTint , _ ) -> [e| withInt |]+ (BTutc , Just (FtrUTC ur)) -> [e| withUTCRange ur |]+ (BTutc , _ ) -> [e| withUTC |]++++{-+instance ToJSON JobSpecId where+ toJSON = \ x ->+ object+ [ "Id" .= jsiId x+ , "Input" .= jsiInput x+ , "Output" .= jsiOutput x+ , "PipelineId" .= jsiPipelineId x+ ]+-}++gen_sr_to :: Tool (APINode, SpecRecord)+gen_sr_to = mkTool $ \ ts (an, sr) -> do+ x <- newName "x"+ optionalInstanceD ts ''ToJSON [nodeRepT an] [simpleD 'toJSON (bdy an sr x)]+ where+ bdy an sr x = lamE [varP x] $+ varE 'object `appE`+ listE [ [e| $(fieldNameE fn) .= $(nodeFieldE an fn) $(varE x) |]+ | (fn, _) <- srFields sr ]+++{-+instance FromJSONWithErrs JobSpecId where+ parseJSONWithErrs (Object v) =+ JobSpecId <$>+ v .: "Id" <*>+ v .: "Input" <*>+ v .: "Output" <*>+ v .: "PipelineId"+ parseJSONWithErrs v = failWith $ expectedObject val+-}++gen_sr_fm :: Tool (APINode, SpecRecord)+gen_sr_fm = mkTool $ \ ts (an, sr) -> do+ x <- newName "x"+ optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]+ [funD 'parseJSONWithErrs [cl an sr x, cl' x]]+ where+ cl an sr x = clause [conP 'Object [varP x]] (normalB bdy) []+ where bdy = applicativeE (nodeConE an) [ [e| $(varE x) .:. $(fieldNameE fn) |]+ | (fn, _) <- srFields sr ]++ cl' x = clause [varP x] (normalB (bdy' x)) []+ bdy' x = [e| failWith (expectedObject $(varE x)) |]+++{-+instance ToJSON Foo where+ toJSON (Bar x) = object [ "x" .= x ]+ toJSON (Baz x) = object [ "y" .= x ]+-}++gen_su_to :: Tool (APINode, SpecUnion)+gen_su_to = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''ToJSON [nodeRepT an] [funD 'toJSON (cls an su)]+ where+ cls an su = map (cl an . fst) (suFields su)++ cl an fn = do x <- newName "x"+ clause [nodeAltConP an fn [varP x]] (bdy fn x) []++ bdy fn x = normalB [e| object [ $(fieldNameE fn) .= $(varE x) ] |]+++{-+instance FromJSONWithErrs Foo where+ parseJSONWithErrs (Object v) = alternatives (failWith $ MissingAlt ["x", "y"])+ [ Bar <$> v .:: "x"+ , Baz <$> v .:: "y"+ ]+ parseJSONWithErrs val = failWith $ expectedObject val+-}++gen_su_fm :: Tool (APINode, SpecUnion)+gen_su_fm = mkTool $ \ ts (an, su) -> do+ x <- newName "x"+ optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]+ [funD 'parseJSONWithErrs (cls an su x)]+ where+ cls an su x = [cl, cl']+ where+ cl = clause [conP 'Object [varP x]] (normalB bdy) []+ bdy = [e| alternatives (failWith $ MissingAlt $ss) $alts |]++ alt fn = [e| fmap $(nodeAltConE an fn) ($(varE x) .:: $(fieldNameE fn)) |]++ alts = listE $ map alt fns+ ss = listE $ map fieldNameE fns++ fns = map fst $ suFields su++ cl' = clause [varP x] (normalB bdy') []+ bdy' = [e| failWith (expectedObject $(varE x)) |]++++{-+instance ToJSON FrameRate where+ toJSON = String . _text_FrameRate+-}++gen_se_to :: Tool (APINode, SpecEnum)+gen_se_to = mkTool $ \ ts (an, _se) -> optionalInstanceD ts ''ToJSON [nodeRepT an] [simpleD 'toJSON (bdy an)]+ where+ bdy an = [e| String . $(varE (text_enum_nm an)) |]+++{-+instance FromJSONWithErrs FrameRate where+ parseJSONWithErrs = jsonStrMap_p _map_FrameRate+-}++gen_se_fm :: Tool (APINode, SpecEnum)+gen_se_fm = mkTool $ \ ts (an, _se) -> optionalInstanceD ts ''FromJSONWithErrs [nodeRepT an]+ [simpleD 'parseJSONWithErrs (bdy an)]+ where+ bdy an = [e| jsonStrMap_p $(varE (map_enum_nm an)) |]+++gen_in :: Tool APINode+gen_in = mkTool $ \ ts an -> case anConvert an of+ Nothing -> return []+ Just (inj_fn, _) -> optionalInstanceD ts ''FromJSONWithErrs [nodeT an]+ [simpleD 'parseJSONWithErrs bdy]+ where+ bdy = do x <- newName "x"+ lamE [varP x] [e| parseJSONWithErrs $(varE x) >>= $inj |]+ inj = varE $ mkName $ _FieldName inj_fn+++gen_pr :: Tool APINode+gen_pr = mkTool $ \ ts an -> case anConvert an of+ Nothing -> return []+ Just (_, prj_fn) -> optionalInstanceD ts ''ToJSON [nodeT an] [simpleD 'toJSON bdy]+ where+ bdy = [e| toJSON . $prj |]+ prj = varE $ mkName $ _FieldName prj_fn+++alternatives :: Alternative t => t a -> [t a] -> t a+alternatives none = foldr (<|>) none++mkInt :: Int -> Value+mkInt = Number . fromInteger . toInteger+++jsonStrMap_p :: Ord a => Map.Map T.Text a -> Value -> ParserWithErrs a+jsonStrMap_p mp = json_string_p (Map.keys mp) $ flip Map.lookup mp++json_string_p :: Ord a => [T.Text] -> (T.Text->Maybe a) -> Value -> ParserWithErrs a+json_string_p xs p (String t) | Just val <- p t = pure val+ | otherwise = failWith $ UnexpectedEnumVal xs t+json_string_p _ _ v = failWith $ expectedString v+++fieldNameE :: FieldName -> ExpQ+fieldNameE = stringE . _FieldName++typeNameE :: TypeName -> ExpQ+typeNameE = stringE . _TypeName
+ src/Data/API/Tools/JSONTests.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}++-- Here we use Template Haskell to generate a test suite for the Aeson wrappers+-- from the DSL description of same.++module Data.API.Tools.JSONTests+ ( jsonTestsTool+ , prop_decodesTo+ , prop_resultsMatchRoundtrip+ ) where++import Data.API.JSON+import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.TH+import Data.API.Types++import qualified Data.Aeson as JS+import Language.Haskell.TH+import Test.QuickCheck+++-- | Tool to generate a list of tests of type @[('String', 'Property')]@+-- with the given name. This depends on 'jsonTool' and 'quickCheckTool'.+jsonTestsTool :: Name -> APITool+jsonTestsTool nm = simpleTool $ \ api -> simpleSigD nm [t| [(String, Property)] |] (props api)+ where+ props api = listE $ map generateProp [ an | ThNode an <- api ]++-- | For an APINode, generate a (String, Property) pair giving the+-- type name and an appropriate instance of the+-- prop_resultsMatchRoundtrip property+generateProp :: APINode -> ExpQ+generateProp an = [e| ($ty, property (prop_resultsMatchRoundtrip :: $(nodeT an) -> Bool)) |]+ where+ ty = stringE $ _TypeName $ anName an+++-- | QuickCheck property that a 'Value' decodes to an expected Haskell+-- value, using 'fromJSONWithErrs'+prop_decodesTo :: forall a . (Eq a, FromJSONWithErrs a)+ => JS.Value -> a -> Bool+prop_decodesTo v x = case fromJSONWithErrs v :: Either [(JSONError, Position)] a of+ Right y | x == y -> True+ _ -> False++-- | QuickCheck property that Haskell values can be encoded with+-- 'toJSON' and decoded with 'fromJSONWithErrs' to get the original+-- value+prop_resultsMatchRoundtrip :: forall a . (Eq a, JS.ToJSON a, FromJSONWithErrs a )+ => a -> Bool+prop_resultsMatchRoundtrip x = prop_decodesTo (JS.toJSON x) x
+ src/Data/API/Tools/Lens.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.API.Tools.Lens+ ( lensTool+ , binary+ ) where++import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.Types++import Control.Lens+++-- | Tool to make lenses for fields in generated types.+lensTool :: APITool+lensTool = apiDataTypeTool $ simpleTool $ makeLenses . rep_type_nm+++$(makeLenses ''Binary)
+ src/Data/API/Tools/QuickCheck.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.API.Tools.QuickCheck+ ( quickCheckTool+ ) where++import Data.API.TH+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+++-- | Tool to generate 'Arbitrary' instances for generated types.+quickCheckTool :: APITool+quickCheckTool = apiNodeTool $ apiSpecTool gen_sn_ab gen_sr_ab gen_su_ab gen_se_ab mempty+++-- | Generate an 'Arbitrary' instance for a newtype that respects its+-- filter. We don't try to generate arbitrary data matching a regular+-- expression, however: instances must be supplied manually. When+-- generating arbitrary integers, use 'arbitraryBoundedIntegral'+-- rather than 'arbitrary' (the latter tends to generate non-unique+-- values).+gen_sn_ab :: Tool (APINode, SpecNewtype)+gen_sn_ab = mkTool $ \ ts (an, sn) -> case snFilter sn of+ Nothing | snType sn == BTint -> mk_instance ts an [e| QC.arbitraryBoundedIntegral |]+ | otherwise -> mk_instance ts an [e| arbitrary |]+ Just (FtrIntg ir) -> mk_instance ts an [e| arbitraryIntRange ir |]+ Just (FtrUTC ur) -> mk_instance ts an [e| arbitraryUTCRange ur |]+ Just (FtrStrg _) -> return []+ where+ mk_instance ts an arb = optionalInstanceD ts ''Arbitrary [nodeRepT an]+ [simpleD 'arbitrary [e| fmap $(nodeConE an) $arb |]]+++-- | Generate an 'Arbitrary' instance for a record:+--+-- > instance Arbitrary Foo where+-- > arbitrary = sized $ \ x -> Foo <$> resize (x `div` 2) arbitrary <*> ... <*> resize (x `div` 2) arbitrary++gen_sr_ab :: Tool (APINode, SpecRecord)+gen_sr_ab = mkTool $ \ ts (an, sr) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an]+ [simpleD 'arbitrary (bdy an sr)]+ where+ -- Reduce size of fields to avoid generating massive test data+ -- by giving an arbitrary implementation like this:+ -- sized (\ x -> JobSpecId <$> resize (x `div` 2) arbitrary <*> ...)+ bdy an sr = do x <- newName "x"+ appE (varE 'QC.sized) $ lamE [varP x] $+ applicativeE (nodeConE an) $+ replicate (length $ srFields sr) $+ [e| QC.resize ($(varE x) `div` 2) arbitrary |]+++-- | Generate an 'Arbitrary' instance for a union:+--+-- > instance Arbitrary Foo where+-- > arbitrary = oneOf [ fmap Bar arbitrary, fmap Baz arbitrary ]++gen_su_ab :: Tool (APINode, SpecUnion)+gen_su_ab = mkTool $ \ ts (an, su) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an]+ [simpleD 'arbitrary (bdy an su)]+ where+ bdy an su | null (suFields su) = nodeConE an+ | otherwise = [e| oneof $(listE alts) |]+ where+ alts = [ [e| fmap $(nodeAltConE an k) arbitrary |]+ | (k, _) <- suFields su ]+++-- | Generate an 'Arbitrary' instance for an enumeration:+--+-- > instance Arbitrary Foo where+-- > arbitrary = elements [Bar, Baz]++gen_se_ab :: Tool (APINode, SpecEnum)+gen_se_ab = mkTool $ \ ts (an, se) -> optionalInstanceD ts ''QC.Arbitrary [nodeRepT an]+ [simpleD 'arbitrary (bdy an se)]+ where+ bdy an se | null ks = nodeConE an+ | otherwise = varE 'elements `appE` listE ks+ where+ ks = map (nodeAltConE an . fst) $ seAlts se+++-- | Generate an arbitrary 'Int' in a given range.+arbitraryIntRange :: IntRange -> Gen Int+arbitraryIntRange (IntRange (Just lo) Nothing ) = QC.choose (lo, maxBound)+arbitraryIntRange (IntRange Nothing (Just hi)) = QC.choose (minBound, hi)+arbitraryIntRange (IntRange (Just lo) (Just hi)) = QC.choose (lo, hi)+arbitraryIntRange (IntRange Nothing Nothing ) = QC.arbitrary++-- | Generate an arbitrary 'UTCTime' in a given range.+-- TODO: we might want to generate a broader range of sample times,+-- rather than just the extrema.+arbitraryUTCRange :: UTCRange -> Gen UTCTime+arbitraryUTCRange (UTCRange (Just lo) Nothing ) = pure lo+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?)+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"+ ]+ where+ mk = fromJustNote lab . parseUTC'++ lab = "Data.API.Tools.QuickCheck.Arbitrary-UTCTime"
+ src/Data/API/Tools/SafeCopy.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.API.Tools.SafeCopy+ ( safeCopyTool+ ) where++import Data.API.Tools.Combinators+import Data.API.Tools.Datatypes+import Data.API.Types++import Data.SafeCopy+++-- | Tool to derive 'SafeCopy' instances for generated types. At+-- present, this derives only base version instances.+safeCopyTool :: APITool+safeCopyTool = apiDataTypeTool $ simpleTool $ deriveSafeCopy 0 'base . rep_type_nm++$(deriveSafeCopy 0 'base ''Binary)
+ src/Data/API/Tutorial.hs view
@@ -0,0 +1,269 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Data.API.Tutorial (+ -- * Introduction+ -- $introduction++ -- * The api DSL+ -- $api++ -- ** Generating types for an API+ -- $generate++ -- * Generating tools for an API+ -- $tools++ -- * Data migration+ -- $migration++ -- ** Custom migrations+ -- $custom++ -- * Documenting a REST-like API+ -- $docs+ ) where++import Data.API.Changes+import Data.API.Doc.Call+import Data.API.Doc.Dir+import Data.API.Doc.Types+import Data.API.JSON+import Data.API.Parse+import Data.API.Tools+import Data.API.Types++import Data.Text+import Data.Time++{- $introduction++The @api-tools@ library provides a compact DSL for describing an API.+It uses Template Haskell to generate the corresponding data types and+assorted tools for working with it, including code for converting+between JSON and the generated types and writing unit tests. It+supports maintaining a log of changes to the API and migrating data+between different versions.++-}++{- $api++An 'API' is a list of datatypes, which must be in one of five+simple forms:++ * Records, which have one constructor but many fields++ * Unions, which have many constructors each with a single argument++ * Enumerations, which have many nullary constructors++ * Newtypes, which wrap a built-in basic type++ * Type synonyms++To define an 'API', you can use the 'parseAPI' function or the 'api'+quasi-quoter, like this:++> example :: API+> example = [api|+>+> rec :: MyRecord+> // A record type containing two fields+> = record+> x :: [integer] // one field+> y :: ? [utc] // another field+>+> chc :: MyChoice+> // A disjoint union+> = union+> | a :: MyRecord+> | b :: string+>+> enm :: MyEnum+> // An enumeration+> = enum+> | e1+> | e2+>+> str :: MyString+> // A newtype+> = basic string+>+> flg :: MyFlag+> // A type synonym+> = boolean+>+> |]++The basic types available (and their Haskell representations) are+@string@ ('Text'), @binary@ ('Binary'), @integer@ ('Int'), @boolean@+('Bool') and @utc@ ('UTCTime').++The prefix (given before the @::@ on each type declaration) is used to+name record fields and enumeration/union constructors in the generated+Haskell code. It must be unique throughout the API. It is not a type+signature, despite the appearance!++-}++{- $generate++Once an API is defined, the 'generate' function can be used in a+Template Haskell splice to produce the corresponding Haskell datatype+declarations. Thus @$(generate example)@ will produce something like:++> data MyRecord = MyRecord { rec_x :: [Int]+> , rec_y :: Maybe [UTCTime]+> }+>+> data MyChoice = CHC_a MyRecord | CHC_b String+>+> data MyEnum = ENM_e1 | ENM_e2+>+> newtype MyString = MyString { _MyString :: String }+>+> type MyFlag = Bool++The Template Haskell staging restriction means that @example@ must be+defined in one module and imported into another to call @generate@.++-}++{- $tools++Once the Haskell datatypes have been created by 'generate', additional+tools can be created with 'generateAPITools'. See "Data.API.Tools"+for a list of tools supplied with the library. For example, the call++> $(generateAPITools [enumTool, jsonTool, quickCheckTool] example)++will define:++* @_text_MyEnum :: MyEnum -> 'Text'@ and @_map_MyEnum :: Map 'Text' MyEnum@,+ for converting between enumerations and text representations++* 'ToJSON', 'FromJSONWithErrs' and 'Arbitrary' instances for all the+ generated types++-}++{- $migration++A key feature of @api-tools@ is support for migrating data between+different versions of an 'API'. The 'apiWithChangelog' quasi-quoter+allows an API to be followed by a changelog in a formal syntax,+providing a record of changes between versions. For example:++> example :: API+> exampleChangelog :: APIChangelog+> (example, exampleChangelog) = [apiWithChangelog|+>+> // ...api specification as before...+>+> changes+>+> version "0.3"+> added MyFlag boolean+>+> version "0.2"+> changed record MyRecord+> field added y :: ? [utc]+>+> // Initial version+> version "0.1"+> |]++The 'migrateDataDump' function can be used to migrate data, encoded+with JSON, from a previous API version to a more recent version. The+old and new 'API's must be supplied, and the changes in the changelog+must describe how to get from the old to the new 'API'. The+'validateChanges' function can be used to check that a changelog is+sufficient.++A changelog consists of the keyword @changes@ and a list of version+blocks. A version block consists of the keyword @version@ starting in+the leftmost column, a version number in double quotes, then a list of+changes. The following changes are available:++> added <Type name> <Specification>+> removed <Type name>+> renamed <Source type> to <Target type>+> changed record <Type name>+> field added <field name> :: <Type> [default <value>]+> field removed <field name>+> field renamed <source field> to <target field>+> field changed <field name> :: <New type> migration <Migration name>+> changed union <Type name>+> alternative added <alternative name> :: <Type>+> alternative removed <alternative name>+> alternative renamed <source alternative> to <target alternative>+> changed enum <Type name>+> alternative added <value name>+> alternative removed <value name>+> alternative renamed <source value> to <target value>+> migration <Migration name>+> migration record <Type name> <Migration name>++-}++{- $custom++For more extensive changes to the 'API' that cannot be expressed using+the primitive changes, /custom/ migrations can be used to migrate data+between versions.++Custom migrations can be applied to the whole dataset, a single record+or an individual record field, thus:++> version "0.42"+> migration MigrateWholeDataset+> migration record Widget MigrateWidgetRecord+> changed record Widget where+> field changed foo :: String migration MigrateFooField++The 'generateMigrationKinds' function creates enumeration types+corresponding to the custom migration names used in a changelog.+These types should then be used to create a 'CustomMigrations' record,+which describes how to transform the data (and 'API', if appropriate)+for each custom migration. For example,++> $(generateMigrationKinds myChangelog "DatabaseMigration" "RecordMigration" "FieldMigration")++with the changelog fragment above would give++> data DatabaseMigration = MigrateWholeDatabase | ...+> data RecordMigration = MigrateWidgetRecord | ...+> data FieldMigration = MigrateFooField | ...++Calls to 'migrateDataDump' should include a suitable+'CustomMigrations' record, which includes functions to perform the+migrations on the underlying data, represented as an Aeson 'Value'.+For example, suppose the @foo@ field of the @Widget@ record previously+contained a boolean: a suitable 'fieldMigration' implementation might be:++> fieldMigration :: FieldMigration -> Value -> Either ValueError Value+> fieldMigration MigrateFooField (Bool b) = Right $ toJSON $ show b+> fieldMigration MigrateFooField v = Left $ CustomMigrationError "oops" v+> ...++A field migration may change the type of the field by listing the new+type in the changelog. Whole-database and individual-record+migrations may describe the changes they make to the schema in the+'databaseMigrationSchema' and 'recordMigrationSchema' fields of the+'CustomMigrations' record.++In order to check that custom migrations result in data that matches+the schema, the 'DataChecks' parameter of 'migrateDataDump' can be set+to 'CheckCustom' or 'CheckAll'. This will validate the data against+the schema after calling the custom migration code.++-}++{- $docs++A 'Call' is a description of a web resource, intended to be generated+in an application-specific way from the code of a web server. The+'callHtml' function can be used to generate HTML documentation of+individual resources, and 'dirHtml' can be used to generate an index+page for the documentation of a collection of resources.++-}
+ src/Data/API/Types.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+++module Data.API.Types+ ( API+ , Thing(..)+ , APINode(..)+ , TypeName(..)+ , FieldName(..)+ , MDComment+ , Prefix+ , Spec(..)+ , SpecNewtype(..)+ , SpecRecord(..)+ , FieldType(..)+ , SpecUnion(..)+ , SpecEnum(..)+ , Conversion+ , APIType(..)+ , DefaultValue(..)+ , BasicType(..)+ , Filter(..)+ , IntRange(..)+ , UTCRange(..)+ , RegEx(..)+ , Binary(..)+ , defaultValueAsJsValue+ ) where++import Data.API.Utils++import qualified Data.CaseInsensitive as CI+import Data.String+import Data.Time+import Data.Aeson+import Data.Aeson.Types+import Data.Aeson.TH+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.ByteString.Char8 as B+import Test.QuickCheck as QC+import Control.Applicative+import qualified Data.ByteString.Base64 as B64+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Text.Regex+++-- | an API spec is made up of a list of type/element specs, each+-- specifying a Haskell type and JSON wrappers++type API = [Thing]++data Thing+ = ThComment MDComment+ | ThNode APINode+ deriving (Show)++-- | Specifies an individual element/type of the API++data APINode+ = APINode+ { anName :: TypeName -- ^ name of Haskell type+ , anComment :: MDComment -- ^ comment describing type in Markdown+ , anPrefix :: Prefix -- ^ distinct short prefix (see below)+ , anSpec :: Spec -- ^ the type specification+ , anConvert :: Conversion -- ^ optional conversion functions+ }+ deriving (Show)++-- | TypeName must contain a valid Haskell type constructor++newtype TypeName = TypeName { _TypeName :: String }+ deriving (Eq, Ord,Show, IsString)++-- | FieldName identifies recod fields and union alternatives+-- must contain a valid identifier valid in Haskell and+-- any API client wrappers (e.g., if Ruby wrappers are to be+-- generated the names should easily map into Ruby)++newtype FieldName = FieldName { _FieldName :: String }+ deriving (Show,Eq,Ord,IsString)++-- | Markdown comments are represented by strings++type MDComment = String++-- | a distinct case-insensitive short prefix used to form unique record field+-- names and data constructors:+--+-- * must be a valid Haskell identifier+--+-- * must be unique within the API++type Prefix = CI.CI String++-- | type/element specs are either simple type isomorphisms of basic JSON+-- types, records, unions or enumerated types++data Spec+ = SpNewtype SpecNewtype+ | SpRecord SpecRecord+ | SpUnion SpecUnion+ | SpEnum SpecEnum+ | SpSynonym APIType+ deriving (Show)++-- | SpecNewtype elements are isomorphisms of string, inetgers or booleans++data SpecNewtype =+ SpecNewtype+ { snType :: BasicType+ , snFilter :: Maybe Filter+ }+ deriving (Show)++data Filter+ = FtrStrg RegEx+ | FtrIntg IntRange+ | FtrUTC UTCRange+ deriving (Show)++data IntRange+ = IntRange+ { ir_lo :: Maybe Int+ , ir_hi :: Maybe Int+ }+ deriving (Eq, Show)++instance Lift IntRange where+ lift (IntRange lo hi) = [e| IntRange lo hi |]++data UTCRange+ = UTCRange+ { ur_lo :: Maybe UTCTime+ , ur_hi :: Maybe UTCTime+ }+ deriving (Eq, Show)++instance Lift UTCRange where+ lift (UTCRange lo hi) = [e| UTCRange $(liftMaybeUTCTime lo) $(liftMaybeUTCTime hi) |]++liftMaybeUTCTime :: Maybe UTCTime -> ExpQ+liftMaybeUTCTime Nothing = [e| Nothing |]+liftMaybeUTCTime (Just u) = [e| parseUTC_ $(stringE (mkUTC_ u)) |]+++data RegEx =+ RegEx+ { re_text :: T.Text+ , re_regex :: Regex+ }++mkRegEx :: T.Text -> RegEx+mkRegEx txt = RegEx txt $ mkRegexWithOpts (T.unpack txt) False True++instance ToJSON RegEx where+ toJSON RegEx{..} = String re_text++instance FromJSON RegEx where+ parseJSON = withText "RegEx" (return . mkRegEx)++instance Eq RegEx where+ r == s = re_text r == re_text s++instance Show RegEx where+ show = T.unpack . re_text++instance Lift RegEx where+ lift re = [e| mkRegEx $(stringE (T.unpack (re_text re))) |]++-- | SpecRecord is your classsic product type.++data SpecRecord = SpecRecord+ { srFields :: [(FieldName, FieldType)]+ }+ deriving (Show)++-- | In addition to the type and comment, record fields may carry a+-- flag indicating that they are read-only, and may have a default+-- value, which must be of a compatible type.++data FieldType = FieldType+ { ftType :: APIType+ , ftReadOnly :: Bool+ , ftDefault :: Maybe DefaultValue+ , ftComment :: MDComment+ }+ deriving (Show)++-- | SpecUnion is your classsic union type++data SpecUnion = SpecUnion+ { suFields :: [(FieldName,(APIType,MDComment))]+ }+ deriving (Show)++-- | SpecEnum is your classic enumerated type++data SpecEnum = SpecEnum+ { seAlts :: [(FieldName,MDComment)]+ }+ deriving (Show)++-- Conversion possibly converts to an internal representation++type Conversion = Maybe (FieldName,FieldName)++-- | Type is either a list, Maybe, a named element of the API or a basic type+data APIType+ = TyList APIType -- ^ list elements are types+ | TyMaybe APIType -- ^ Maybe elements are types+ | 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)++-- | the basic JSON types (N.B., no floating point numbers, yet)+data BasicType+ = BTstring -- ^ a JSON UTF-8 string+ | BTbinary -- ^ a base-64-encoded byte string+ | BTbool -- ^ a JSON bool+ | BTint -- ^ a JSON integral number+ | BTutc -- ^ a JSON UTC string+ deriving (Eq, Show)++-- | A default value for a field+data DefaultValue+ = DefValList+ | DefValMaybe+ | DefValString T.Text -- used for binary fields (base64 encoded)+ | DefValBool Bool+ | DefValInt Int+ | DefValUtc UTCTime+ deriving (Eq, Show)++-- | Convert a default value to an Aeson 'Value'. This differs from+-- 'toJSON' as it will not round-trip with 'fromJSON': UTC default+-- values are turned into strings.+defaultValueAsJsValue :: DefaultValue -> Value+defaultValueAsJsValue DefValList = toJSON ([] :: [()])+defaultValueAsJsValue DefValMaybe = Null+defaultValueAsJsValue (DefValString s) = String s+defaultValueAsJsValue (DefValBool b) = Bool b+defaultValueAsJsValue (DefValInt n) = Number (fromIntegral n)+defaultValueAsJsValue (DefValUtc t) = mkUTC t+++-- | Binary data is represented in JSON format as a base64-encoded+-- string+newtype Binary = Binary { _Binary :: B.ByteString }+ deriving (Show,Eq,Ord)++instance ToJSON Binary where+ toJSON = String . T.decodeLatin1 . B64.encode . _Binary++instance FromJSON Binary where+ parseJSON = withBinary "Binary" return++instance QC.Arbitrary T.Text where+ arbitrary = T.pack <$> QC.arbitrary++instance QC.Arbitrary Binary where+ arbitrary = Binary <$> B.pack <$> QC.arbitrary++withBinary :: String -> (Binary->Parser a) -> Value -> Parser a+withBinary lab f = withText lab g+ where+ g t =+ case B64.decode $ T.encodeUtf8 t of+ Left _ -> typeMismatch lab (String t)+ Right bs -> f $ Binary bs+++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
@@ -0,0 +1,55 @@+module Data.API.Utils+ ( mkUTC+ , mkUTC'+ , mkUTC_+ , parseUTC'+ , parseUTC_+ , (?!)+ , (?!?)+ ) where++import Data.Aeson+import Data.Maybe+import qualified Data.Text as T+import Data.Time+import System.Locale+++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++parseUTC_ :: String -> Maybe UTCTime+parseUTC_ s = listToMaybe $ catMaybes $+ map (\fmt->parseTime defaultTimeLocale fmt s) utcFormats+++-- | The \"oh noes!\" operator.+--+(?!) :: Maybe a -> e -> Either e a+Nothing ?! e = Left e+Just x ?! _ = Right x++(?!?) :: Either e a -> (e -> e') -> Either e' a+Left e ?!? f = Left (f e)+Right x ?!? _ = Right x
+ tests/Data/API/Test/DSL.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -XNoCPP #-}++module Data.API.Test.DSL where++import Data.API.Parse+import Data.API.Types+++example :: API+example = map ThNode + [ APINode "IsoS" "simple String newtype defn" ""+ (SpNewtype $ SpecNewtype BTstring Nothing) Nothing+ , APINode "IsoB" "simple Bool newtype defn" ""+ (SpNewtype $ SpecNewtype BTbool Nothing) Nothing+ , APINode "IsoI" "simple Int newtype defn" ""+ (SpNewtype $ SpecNewtype BTint Nothing) Nothing+ , APINode "Foo" "a test defn" "bAr_" (SpRecord $ SpecRecord+ [ (,) "Baz" (FieldType (TyBasic BTbool) False Nothing "just a bool")+ , (,) "Qux" (FieldType (TyBasic BTint) False Nothing "just an int")+ ]) Nothing+ , APINode "Wibble" "another test defn" "dro" (SpUnion $ SpecUnion+ [ (,) "wubble" (TyList $ TyName "Foo", "list of Foo")+ , (,) "flubble" (TyBasic BTstring , "a string" )+ ]) Nothing+ , APINode "Enumer" "enum test defn" "enm" (SpEnum $ SpecEnum+ [ ("wubble", "")+ , ("flubble", "")+ ]) Nothing+ ]++example2 :: API+example2 = [api|++ssn :: Ssn+ = basic integer+ with inj_ssn, prj_ssn++ide :: Ide+ (* here is a block comment *)+ // and a simple comment+ = string++flg :: Flag+ = boolean++crt :: Cert+ = binary++poo :: Poo+ // A simple test example+ = record+ x :: integer+ y :: Foo++c :: Coord+ // A simple test example+ = record+ x :: integer // the x coordinate+ // with a multi-line comment+ y :: integer (* and here we have a multi-line+ block comment + and this + *)+ with inj_coord, prj_coord++twi :: Twiddle+ // A simple test example+ = record+ x :: [integer] // a field+ y :: ? [binary] // another field++chc :: CHOICE+ = union+ | a :: integer+ | b :: string+ with inj_chc, prj_chc++enm :: ENUM+ = enum+ | e1+ | e2+ with inj_enum, prj_enum++uv :: MyUTC+ = utc++urec :: URec+ = record+ foo :: utc+|]
+ tests/Data/API/Test/Gen.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Data.API.Test.Gen where++import Data.API.JSON+import Data.API.Test.DSL hiding (example)+import qualified Data.API.Test.DSL as DSL+import Data.API.Tools+import Data.API.Tools.Example+import Control.Applicative+import Language.Haskell.TH+import Test.QuickCheck++$(generate DSL.example)+$(generateAPITools DSL.example+ [ enumTool+ , jsonTool+ , quickCheckTool+ , lensTool+ , safeCopyTool+ , exampleTool+ , samplesTool (mkName "exampleSamples")+ , jsonTestsTool (mkName "exampleSimpleTests")+ ])++$(generate example2)++data Coord = Coord Int Int+ deriving (Eq,Show)++instance Arbitrary Coord where+ arbitrary = Coord <$> arbitrary <*> arbitrary++instance Example Coord++inj_coord :: REP__Coord -> ParserWithErrs Coord+inj_coord (REP__Coord x y) = pure $ Coord x y++prj_coord :: Coord -> REP__Coord +prj_coord (Coord x y) = REP__Coord x y+++newtype Ssn = Ssn { _Ssn :: Integer }+ deriving(Eq,Show)++instance Arbitrary Ssn where+ arbitrary = Ssn <$> arbitrary++instance Example Ssn++inj_ssn :: REP__Ssn -> ParserWithErrs Ssn+inj_ssn = return . Ssn . fromIntegral . _REP__Ssn++prj_ssn :: Ssn -> REP__Ssn+prj_ssn = REP__Ssn . fromIntegral . _Ssn+++data CHOICE = CHOICE { _CHOICE :: Int }+ deriving(Eq,Show)++instance Arbitrary CHOICE where+ arbitrary = CHOICE <$> arbitrary++instance Example CHOICE++inj_chc :: REP__CHOICE -> ParserWithErrs CHOICE+inj_chc (CHC_a i) = return $ CHOICE i+inj_chc (CHC_b _) = empty++prj_chc :: CHOICE -> REP__CHOICE+prj_chc (CHOICE i) = CHC_a i++newtype ENUM = ENUM Bool+ deriving (Show,Eq)++instance Arbitrary ENUM where+ arbitrary = ENUM <$> arbitrary++instance Example ENUM++inj_enum :: REP__ENUM -> ParserWithErrs ENUM+inj_enum ENM_e1 = return $ ENUM False+inj_enum ENM_e2 = return $ ENUM True++prj_enum :: ENUM -> REP__ENUM+prj_enum (ENUM False) = ENM_e1+prj_enum (ENUM True ) = ENM_e2++$(generateAPITools example2+ [ enumTool+ , jsonTool+ , quickCheckTool+ , lensTool+ , safeCopyTool+ , exampleTool+ , samplesTool (mkName "example2Samples")+ , jsonTestsTool (mkName "example2SimpleTests")+ ])
+ tests/Data/API/Test/JSON.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}++module Data.API.Test.JSON+ ( jsonTests+ ) where++import Data.API.API.Gen+import Data.API.JSON+import Data.API.Tools+import Data.API.Tools.JSONTests+import Data.API.Test.Gen (exampleSimpleTests, example2SimpleTests)+import Data.API.Test.MigrationData++import qualified Data.Aeson as JS+import qualified Data.HashMap.Strict as HMap++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+++$(generate startSchema)+$(generateAPITools startSchema+ [ enumTool+ , jsonTool+ , quickCheckTool+ ])++-- | Test that literals are decoded correctly, including the dubious+-- use of strings for numbers and numbers for booleans, and missing+-- fields being treated as nulls.+basicValueDecoding :: Assertion+basicValueDecoding = sequence_ [ help (JS.String "12") (12 :: Int) True+ , help (JS.String "0") (0 :: Int) True+ , help (JS.String "-9") (-9 :: Int) True+ , help (JS.String "1a") (1 :: Int) False+ , help (JS.Number 0) False True+ , help (JS.Number 1) True True+ , help (JS.Number 2) True False+ , help (JS.String "0") False False+ , help (JS.String "1") True False+ , help (JS.Object (HMap.singleton "id" (JS.Number 3)))+ (Recursive (Id 3) Nothing)+ True+ ]+ where+ help v x yes = assertBool ("Failed on " ++ show v ++ " " ++ show x)+ (prop_decodesTo v x == yes)++-- | Test that the correct errors are generated for bad JSON data+errorDecoding :: [TestTree]+errorDecoding = [ help "not enough bytes" "" (proxy :: Int)+ [(SyntaxError "not enough bytes", [])]+ , help "object for int" "{}" (proxy :: Int)+ [(Expected ExpInt "Int" (JS.Object HMap.empty), [])]+ , help "missing alt" "{}" (proxy :: AUnion)+ [(MissingAlt ["bar"], [])]+ , help "unexpected value" "[\"no\"]" (proxy :: [AnEnum])+ [(UnexpectedEnumVal ["bar", "foo"] "no", [InElem 0])]+ , help "missing field" "{}" (proxy :: Bar)+ [(MissingField, [InField "id"])]+ ]+ where+ proxy = error "proxy"++ help x s v es = testCase x $ case decodeWithErrs s `asTypeOf` Right v of+ Right _ -> assertFailure $ "Decode returned value: " ++ show s+ Left es' -> assertBool ("Unexpected error when decoding: " ++ show s+ ++ "\n" ++ prettyJSONErrorPositions es'+ ++ "\ninstead of\n" ++ prettyJSONErrorPositions es)+ (es == es')++jsonTests :: TestTree+jsonTests = testGroup "JSON"+ [ testCase "Basic value decoding" basicValueDecoding+ , testGroup "Decoding invalid data" errorDecoding+ , testGroup "Round-trip tests"+ [ testGroup "example" $ map (uncurry testProperty) exampleSimpleTests+ , testGroup "example2" $ map (uncurry testProperty) example2SimpleTests+ , testGroup "api" $ map (uncurry testProperty) apiAPISimpleTests+ ]+ ]
+ tests/Data/API/Test/Main.hs view
@@ -0,0 +1,16 @@+module Data.API.Test.Main+ ( main+ ) where++import Data.API.Test.JSON+import Data.API.Test.Migration++import Test.Tasty++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "api-tools" [ migrationTests+ , jsonTests+ ]
+ tests/Data/API/Test/Migration.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -XNoCPP -fno-warn-unused-binds #-}++module Data.API.Test.Migration+ ( migrationTests+ ) where++import Data.API.Changes+import Data.API.PP+import Data.API.Tools+import Data.API.Test.MigrationData+import Data.API.Types+import Data.API.Utils++import qualified Data.Aeson as JS+import qualified Data.Aeson.Encode.Pretty as JS+import Data.Attoparsec.Number+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.HashMap.Strict as HMap+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Version+import Test.Tasty as Test+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck.Property as P+++$(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")+++-- Test of a whole-database migration: copy data between tables+testDatabaseMigration :: TestDatabaseMigration -> JS.Object -> Either ValueError JS.Object+testDatabaseMigration DuplicateBar x = do+ bar <- HMap.lookup "bar" x ?! CustomMigrationError "missing bar" (JS.Object x)+ return $ HMap.insert "bar2" bar x+testDatabaseMigration DuplicateRecursive x = do+ recur <- HMap.lookup "recur" x ?! CustomMigrationError "missing recur" (JS.Object x)+ return $ HMap.insert "recur2" recur x++testDatabaseMigrationSchema :: TestDatabaseMigration -> NormAPI -> Maybe NormAPI+testDatabaseMigrationSchema DuplicateBar _ = Nothing+testDatabaseMigrationSchema DuplicateRecursive napi =+ let Just recur = Map.lookup (TypeName "Recursive") napi+ Just (NRecordType dbs) = Map.lookup root_ napi+ dbs' = Map.insert (FieldName "recur2") (TyMaybe (TyList (TyName "DuplicateRecursive"))) dbs+ in Just $ Map.insert (TypeName "DuplicateRecursive") recur $+ Map.insert root_ (NRecordType dbs') napi+++-- Test of a single-record migration: copy the value in the id field+-- onto the end of the c field+testRecordMigration :: TestRecordMigration -> JS.Object -> Either ValueError JS.Object+testRecordMigration CopyIDtoC x = do+ i <- HMap.lookup "id" x ?! CustomMigrationError "missing id" (JS.Object x)+ b <- HMap.lookup "c" x ?! CustomMigrationError "missing b" (JS.Object x)+ r <- case (i, b) of+ (JS.Number (I j), JS.String t)+ -> return $ JS.String $ t `T.append` T.pack (show j)+ _ -> Left $ CustomMigrationError "bad data" (JS.Object x)+ return $ HMap.insert "c" r x+testRecordMigration DuplicateNew x = do+ new <- HMap.lookup "new" x ?! CustomMigrationError "missing new" (JS.Object x)+ return $ HMap.insert "newnew" new x++testRecordMigrationSchema :: TestRecordMigration -> NormRecordType -> Maybe NormRecordType+testRecordMigrationSchema CopyIDtoC _ = Nothing+testRecordMigrationSchema DuplicateNew r =+ Just $ Map.insert (FieldName "newnew") (TyBasic BTstring) r++-- Test of a single-field migration: change the type of the field from+-- binary to string by base64-decoding the contents+testFieldMigration :: TestFieldMigration -> JS.Value -> Either ValueError JS.Value+testFieldMigration ConvertBinaryToString v@(JS.String s) =+ case B64.decode (B.pack (T.unpack s)) of+ Left err -> Left (CustomMigrationError err v)+ Right x -> return (JS.String (T.pack (B.unpack x)))+testFieldMigration ConvertBinaryToString v = Left $ CustomMigrationError "bad data" v+++testMigration :: CustomMigrations TestDatabaseMigration TestRecordMigration TestFieldMigration+testMigration = CustomMigrations testDatabaseMigration testDatabaseMigrationSchema+ testRecordMigration testRecordMigrationSchema+ testFieldMigration+++assertMatchesAPI :: String -> API -> JS.Value -> Assertion+assertMatchesAPI x a v = case dataMatchesAPI root_ a v of+ Right () -> return ()+ Left err -> assertFailure (x ++ ": " ++ prettyValueErrorPosition err)++basicMigrationTest :: Assertion+basicMigrationTest = do+ assertMatchesAPI "Start data does not match start API" startSchema startData+ assertMatchesAPI "End data does not match end API" endSchema endData+ case migrateDataDump (startSchema, startVersion) (endSchema, DevVersion)+ changelog testMigration root_ CheckAll startData of+ Right (v, []) | endData == v -> return ()+ | otherwise -> assertFailure $ "expected:\n"+ ++ BL.unpack (JS.encodePretty endData)+ ++ "\nbut got:\n"+ ++ BL.unpack (JS.encodePretty v)+ Right (_, ws) -> assertFailure $ "Unexpcted warnings: " ++ show ws+ Left err -> assertFailure (prettyMigrateFailure err)++applyFailureTest :: (Version, Version, ApplyFailure) -> Test.TestTree+applyFailureTest (ver, ver', expected) =+ testCase (showVersion ver ++ " -> " ++ showVersion ver') $+ case migrateDataDump (startSchema, ver) (endSchema, Release ver')+ badChangelog testMigration root_ CheckAll startData of+ Right _ -> assertFailure $ "Successful migration!"+ Left (ValidateFailure (ChangelogEntryInvalid _ _ err))+ | err == expected -> return ()+ Left err -> assertFailure $ unlines $ ["Unexpected failure:"]+ ++ indent (ppLines err) ++ ["Expecting:"]+ ++ indent (ppLines expected)++migrateFailureTest :: MigrateFailureTest+ -> Test.TestTree+migrateFailureTest (s, start, end, clog, db, expected) =+ testCase s $ case migrateDataDump start end clog testMigration root_ CheckAll db of+ Right _ -> assertFailure $ "Successful migration!"+ Left err | expected err -> return ()+ | otherwise -> assertFailure $ unlines $ ["Unexpected failure:"]+ ++ indent (ppLines err)+++$(generate startSchema)+$(generateAPITools startSchema+ [ enumTool+ , jsonTool+ , quickCheckTool+ ])++validMigrationProperty :: DatabaseSnapshot -> P.Result+validMigrationProperty db =+ case migrateDataDump (startSchema, startVersion) (endSchema, DevVersion)+ changelog testMigration root_ CheckStartAndEnd (JS.toJSON db) of+ Right (v, []) -> case dataMatchesAPI root_ endSchema v of+ Right _ -> succeeded+ Left err -> failedBecause ("end data does not match API: "+ ++ prettyValueErrorPosition err)+ Right (_, ws) -> failedBecause ("migration generated warnings: " ++ show ws)+ Left err -> failedBecause ("migration failed: " ++ prettyMigrateFailure err)+ where+ failedBecause e = P.MkResult (Just False) True e False False [] []+++migrationTests :: TestTree+migrationTests = testGroup "Migration"+ [ testCase "Basic migration using sample changelog" basicMigrationTest+ , testGroup "Invalid changes" $ map applyFailureTest expectedApplyFailures+ , testGroup "Invalid migrations" $ map migrateFailureTest expectedMigrateFailures+ , testProperty "Valid migrations" validMigrationProperty+ ]
+ tests/Data/API/Test/MigrationData.hs view
@@ -0,0 +1,606 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-}++-- This module provides data for Data.API.Test.Migration; it is+-- separated out because of the Template Haskell staging restriction.++module Data.API.Test.MigrationData 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.Set as Set+import qualified Data.Text as T+import Data.Version+import Distribution.Text (simpleParse)+++startSchema :: API+startSchema = [api|++id :: Id+ = basic integer++idId :: IdId+ = Id++an_enum :: AnEnum+ = enum+ | foo+ | bar++another_enum :: AnotherEnum+ = enum+ | foo+ | woo++a_union :: AUnion+ = union+ | bar :: Bar++another_union :: AnotherUnion+ = union+ | foo :: Foo+ | woo :: Id++dbs :: DatabaseSnapshot+ = record+ foo :: ? [Foo] nothing+ bar :: ? [Bar] []+ recur :: ? [Recursive]++fooPrefix :: Foo+ = record+ id :: Id+ nest :: Nested+ en :: AnEnum+ un :: AUnion+ quux :: ? IdId++barPrefix :: Bar+ = record+ id :: Id++nestedPrefix :: Nested+ = record+ id :: Id++recursive :: Recursive+ = record+ id :: Id+ recur :: ? Recursive++|]+++endSchema :: API+changelog :: APIChangelog+(endSchema, changelog) = [apiWithChangelog|++id :: Id+ = basic integer++idId :: IdId+ = Id++bin :: Binary+ = basic binary++an_enum :: AnEnum+ = enum+ | foofoo+ | bar+ | baz++another_enum :: AnotherEnum+ = enum+ | foo+ | woo+ | barbar++a_union :: AUnion+ = union+ | barbar :: RenamedBar+ | baz :: Baz++another_union :: AnotherUnion+ = union+ | foo :: Foo+ | woo :: Id+ | barbar :: RenamedBar++dbs :: DatabaseSnapshot+ = record+ foo :: ? [Foo]+ bar2 :: ? [Bar2]+ boz :: ? [Baz]+ recur :: ? [Recursive]+ recur2 :: ? [DuplicateRecursive]++fooPrefix :: Foo+ = record+ id :: Id+ nest :: RenamedNested+ en :: AnEnum+ un :: AUnion+ c :: string+ nolist :: [string]+ nomaybe :: ? string++barPrefix :: RenamedBar+ = record+ id :: Id++bar2Prefix :: Bar2+ = record+ id :: Id++nestedPrefix :: RenamedNested+ = record+ id :: Id+ new :: string++bazPrefix :: Baz+ = record+ id :: Id+ yy :: string++recursive :: Recursive+ = record+ renamed_id :: Id+ recur :: ? Recursive+ new :: string+ newnew :: string++duplicaterecursive :: DuplicateRecursive+ = record+ renamed_id :: Id+ recur :: ? Recursive+ new :: string++new :: New+ = basic integer++changes++version "development"+ // changes since last release+ added New basic integer++version "2.6"+ // add fields with implicit default values+ changed record Foo+ field added nolist :: [string]+ field added nomaybe :: ? string++version "2.5"+ // schema-changing custom record migration+ migration record Recursive DuplicateNew++version "2.4"+ // schema-changing custom database migration+ migration DuplicateRecursive++version "2.3"+ // changing a recursively defined record+ changed record Recursive+ field renamed id to renamed_id+ field added new :: string default "hello"++version "2.2"+ // changing a nested union+ changed union AUnion+ alternative renamed bar to barbar++version "2.1"+ // Changing a nested enum+ changed enum AnEnum+ alternative renamed foo to foofoo++version "2.0"+ // Changing a nested record+ changed record RenamedNested+ field added new :: string default "hello"++version "1.9"+ // Deleting a table+ changed record DatabaseSnapshot+ field removed bar++version "1.8"+ // Renaming a table+ changed record DatabaseSnapshot+ field renamed baz to boz++version "1.7"+ // Adding a table+ changed record DatabaseSnapshot+ field added baz :: ? [Baz] default []++version "1.6"+ // Custom change to the whole database+ migration DuplicateBar+ changed record DatabaseSnapshot+ field added bar2 :: ? [Bar2] default nothing+ added Bar2 record+ id :: Id++version "1.5"+ // Custom change to a record+ migration record Foo CopyIDtoC++version "1.4"+ // Renaming enum values+ changed enum AnotherEnum+ alternative renamed bar to barbar++version "1.3"+ // Deleting enum values+ changed enum AnotherEnum+ alternative removed baz++version "1.2"+ // Adding enum values+ changed enum AnEnum+ alternative added baz+ changed enum AnotherEnum+ alternative added bar+ alternative added baz++version "1.1"+ // Renaming union alternatives+ changed union AnotherUnion+ alternative renamed bar to barbar++version "1.0"+ // Deleting union alternatives+ changed union AnotherUnion+ alternative removed baz++version "0.9"+ // Adding union alternatives+ changed union AUnion+ alternative added baz :: Baz+ changed union AnotherUnion+ alternative added bar :: RenamedBar+ alternative added baz :: Baz++version "0.8"+ // Custom migration on fields+ changed record Foo+ field changed c :: string migration ConvertBinaryToString++version "0.7"+ // Renaming fields+ changed record Foo+ field renamed b to c+ changed record Baz+ field renamed y to yy++version "0.6"+ // Deleting fields+ changed record Foo+ field removed quux+ changed record Baz+ field removed x++version "0.5"+ // Adding fields+ changed record Foo+ field added b :: Binary default "Zm9vYmFy"+ changed record Baz+ field added x :: integer+ field added y :: string++version "0.4"+ // Renaming types+ renamed Nested to RenamedNested+ renamed Bar to RenamedBar++version "0.3"+ // Deleting types+ removed ASynonym++version "0.2"+ // Adding types+ added ASynonym Binary+ added Binary basic binary+ added Baz record+ id :: Id++version "0.1"+ // No changes++version "0"++|]+++badChangelog :: APIChangelog+(_, badChangelog) = [apiWithChangelog|+changes++version "3.1"+ // Adding a table without a default+ changed record DatabaseSnapshot+ field added badtable :: Nested++version "3.0"+ // Renaming to an existing val+ changed enum AnotherEnum+ alternative renamed foo to woo++version "2.9"+ // Renaming a missing val+ changed enum AnotherEnum+ alternative renamed missing to also_missing++version "2.8"+ // Deleting a missing val+ changed enum AnotherEnum+ alternative removed missing++version "2.7"+ // Adding a val that already exists+ changed enum AnEnum+ alternative added bar++version "2.6"+ // Removing vals from a type in use+ changed enum AnEnum+ alternative removed foo++version "2.5"+ // Adding vals to a non-existent type+ changed enum NotThere+ alternative added oops++version "2.4"+ // Adding vals to a non-enum+ changed enum Id+ alternative added oops++version "2.3"+ // Renaming to an existing alt+ changed union AnotherUnion+ alternative renamed foo to woo++version "2.2"+ // Renaming a missing alt+ changed union AnotherUnion+ alternative renamed missing to also_missing++version "2.1"+ // Deleting a missing alt+ changed union AnotherUnion+ alternative removed missing++version "2.0"+ // Adding an alt that already exists+ changed union AUnion+ alternative added bar :: Bar++version "1.9"+ // Adding an alt with a malformed type+ changed union AUnion+ alternative added oops :: Missing++version "1.8"+ // Removing alts from a type in use+ changed union AUnion+ alternative removed foo++version "1.7"+ // Adding alts to a non-existent type+ changed union NotThere+ alternative added oops :: Id++version "1.6"+ // Adding alts to a non-union+ changed union Id+ alternative added oops :: Id++version "1.5"+ // Renaming to an existing field+ changed record Foo+ field renamed en to un++version "1.4"+ // Renaming a missing field+ changed record Foo+ field renamed missing to also_missing++version "1.3"+ // Deleting a missing field+ changed record Foo+ field removed missing++version "1.2"+ // Adding a field with an ill-typed default value+ changed record Foo+ field added oops :: Id default "hello"++version "1.1"+ // Adding a field without a default value+ changed record Foo+ field added oops :: Id++version "1.0"+ // Adding a field that already exists+ changed record Foo+ field added id :: Id++version "0.9"+ // Adding a field with a malformed type+ changed record Foo+ field added oops :: Missing++// // This is now legal:+// version "0.8"+// // Adding fields to a type in use+// changed record Nested+// field added oops :: Id++version "0.7"+ // Adding fields to a non-existent type+ changed record NotThere+ field added oops :: Id++version "0.6"+ // Adding fields to a non-record+ changed record Id+ field added oops :: Id++version "0.5"+ // Renaming to an existing type+ renamed Id to AnEnum++version "0.4"+ // Renaming a missing type+ renamed NotThere to SomethingElse++version "0.3"+ // Deleting a missing type+ removed NotThere++version "0.2"+ // Adding an ill-formed type+ added New Missing++version "0.1"+ // Adding a type that already exists+ added Id basic binary++version "0"+|]++expectedApplyFailures :: [(Version, Version, ApplyFailure)]+expectedApplyFailures = map toVersions $+ [ ("0", "0.1", TypeExists (TypeName "Id"))+ , ("0.1", "0.2", DeclMalformed (TypeName "New")+ (NTypeSynonym (TyName (TypeName "Missing")))+ (Set.singleton (TypeName "Missing")))+ , ("0.2", "0.3", TypeDoesNotExist (TypeName "NotThere"))+ , ("0.3", "0.4", TypeDoesNotExist (TypeName "NotThere"))+ , ("0.4", "0.5", TypeExists (TypeName "AnEnum"))+ , ("0.5", "0.6", TypeWrongKind (TypeName "Id") TKRecord)+ , ("0.6", "0.7", TypeDoesNotExist (TypeName "NotThere"))+-- , ("0.7", "0.8", TypeInUse (TypeName "Nested"))+ , ("0.8", "0.9", TypeMalformed+ (TyName (TypeName "Missing"))+ (Set.singleton (TypeName "Missing")))+ , ("0.9", "1.0", FieldExists (TypeName "Foo") TKRecord (FieldName "id"))+ , ("1.0", "1.1", DefaultMissing (TypeName "Foo") (FieldName "oops"))+ , ("1.1", "1.2", FieldBadDefaultValue (TypeName "Foo") (FieldName "oops")+ (TyName (TypeName "Id")) (DefValString (T.pack "hello")))+ , ("1.2", "1.3", FieldDoesNotExist (TypeName "Foo") TKRecord (FieldName "missing"))+ , ("1.3", "1.4", FieldDoesNotExist (TypeName "Foo") TKRecord (FieldName "missing"))+ , ("1.4", "1.5", FieldExists (TypeName "Foo") TKRecord (FieldName "un"))+ , ("1.5", "1.6", TypeWrongKind (TypeName "Id") TKUnion)+ , ("1.6", "1.7", TypeDoesNotExist (TypeName "NotThere"))+ , ("1.7", "1.8", TypeInUse (TypeName "AUnion"))+ , ("1.8", "1.9", TypeMalformed+ (TyName (TypeName "Missing"))+ (Set.singleton (TypeName "Missing")))+ , ("1.9", "2.0", FieldExists (TypeName "AUnion") TKUnion (FieldName "bar"))+ , ("2.0", "2.1", FieldDoesNotExist (TypeName "AnotherUnion") TKUnion (FieldName "missing"))+ , ("2.1", "2.2", FieldDoesNotExist (TypeName "AnotherUnion") TKUnion (FieldName "missing"))+ , ("2.2", "2.3", FieldExists (TypeName "AnotherUnion") TKUnion (FieldName "woo"))+ , ("2.3", "2.4", TypeWrongKind (TypeName "Id") TKEnum)+ , ("2.4", "2.5", TypeDoesNotExist (TypeName "NotThere"))+ , ("2.5", "2.6", TypeInUse (TypeName "AnEnum"))+ , ("2.6", "2.7", FieldExists (TypeName "AnEnum") TKEnum (FieldName "bar"))+ , ("2.7", "2.8", FieldDoesNotExist (TypeName "AnotherEnum") TKEnum (FieldName "missing"))+ , ("2.8", "2.9", FieldDoesNotExist (TypeName "AnotherEnum") TKEnum (FieldName "missing"))+ , ("2.9", "3.0", FieldExists (TypeName "AnotherEnum") TKEnum (FieldName "woo"))+ , ("3.0", "3.1", DefaultMissing (TypeName "DatabaseSnapshot") (FieldName "badtable"))+ ]+ where+ toVersions (s, s', x)+ | Just v <- simpleParse s+ , Just v' <- simpleParse s'+ , v < v' = (v, v', x)+ | otherwise = error $ "expectedApplyFailures: bad versions "+ ++ show s ++ " and " ++ show s'++type MigrateFailureTest = ( String+ , (API, Version) -- Start version+ , (API, VersionExtra) -- End version+ , APIChangelog+ , JS.Value+ , MigrateFailure -> Bool )++expectedMigrateFailures :: [MigrateFailureTest]+expectedMigrateFailures =+ [ ( "Out of order"+ , (startSchema, ver "0.1")+ , (endSchema, verRelease "0.2")+ , outOfOrder+ , startData+ , (== ValidateFailure (ChangelogOutOfOrder (verRelease "0.1") (verRelease "0.2")))+ )++ , ("Incomplete"+ , (startSchema, ver "0.1")+ , (endSchema, verRelease "2.5")+ , incomplete+ , startData+ , \ err -> case err of+ ValidateFailure (ChangelogIncomplete _ _ _) -> True+ _ -> False+ )++ , ( "Downgrade"+ , (startSchema, ver "0.2")+ , (startSchema, verRelease "0.1")+ , changelog+ , startData+ , (== ValidateFailure (CannotDowngrade (verRelease "0.2") (verRelease "0.1")))+ )++ , ("Bad custom migration"+ , (startSchema, ver "0.1")+ , (startSchema, verRelease "0.2")+ , badCustomMigration+ , startData+ , \ err -> case err of+ ValueError (JSONError UnexpectedField) [InField t] -> t == "bar2"+ _ -> False+ )+ ]+ where+ ver s | Just v <- simpleParse s = v+ | otherwise = error $ "expectedValidateFailures: bad version " ++ show s+ verRelease s = Release $ ver s++ outOfOrder = snd [apiWithChangelog|+changes+version "0.1"+version "0.2"+|]++ incomplete = snd [apiWithChangelog|+changes+version "0.1"+|]++ badCustomMigration = snd [apiWithChangelog|+changes+version "0.2"+ migration DuplicateBar+version "0.1"+|]+++startData, endData :: JS.Value+Just startData = JS.decode "{ \"foo\": [ {\"id\": 42, \"nest\": { \"id\": 3 }, \"en\": \"foo\", \"un\": { \"bar\": { \"id\": 43 } }, \"quux\": null } ], \"bar\": [ { \"id\": 4 } ], \"recur\": [{ \"id\": 9, \"recur\": { \"id\": 8, \"recur\": null} }] }"+Just endData = JS.decode "{ \"foo\": [ {\"id\":42, \"nest\": { \"id\": 3, \"new\": \"hello\" }, \"c\": \"foobar42\", \"en\": \"foofoo\", \"un\": { \"barbar\": { \"id\": 43 } }, \"nolist\": [], \"nomaybe\": null } ], \"boz\": [], \"bar2\": [ {\"id\": 4 } ], \"recur\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }], \"recur2\": [{ \"renamed_id\": 9, \"new\": \"hello\", \"recur\": { \"renamed_id\": 8, \"new\": \"hello\", \"newnew\": \"hello\", \"recur\": null} }] }"++startVersion :: Version+startVersion = changelogStartVersion changelog++root_ :: TypeName+root_ = TypeName "DatabaseSnapshot"