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
type API = [Thing]
data Thing
= ThComment MDComment
| ThNode APINode
deriving (Show)
data APINode
= APINode
{ anName :: TypeName
, anComment :: MDComment
, anPrefix :: Prefix
, anSpec :: Spec
, anConvert :: Conversion
}
deriving (Show)
newtype TypeName = TypeName { _TypeName :: String }
deriving (Eq, Ord,Show, IsString)
newtype FieldName = FieldName { _FieldName :: String }
deriving (Show,Eq,Ord,IsString)
type MDComment = String
type Prefix = CI.CI String
data Spec
= SpNewtype SpecNewtype
| SpRecord SpecRecord
| SpUnion SpecUnion
| SpEnum SpecEnum
| SpSynonym APIType
deriving (Show)
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))) |]
data SpecRecord = SpecRecord
{ srFields :: [(FieldName, FieldType)]
}
deriving (Show)
data FieldType = FieldType
{ ftType :: APIType
, ftReadOnly :: Bool
, ftDefault :: Maybe DefaultValue
, ftComment :: MDComment
}
deriving (Show)
data SpecUnion = SpecUnion
{ suFields :: [(FieldName,(APIType,MDComment))]
}
deriving (Show)
data SpecEnum = SpecEnum
{ seAlts :: [(FieldName,MDComment)]
}
deriving (Show)
type Conversion = Maybe (FieldName,FieldName)
data APIType
= TyList APIType
| TyMaybe APIType
| TyName TypeName
| TyBasic BasicType
| TyJSON
deriving (Eq, Show)
data BasicType
= BTstring
| BTbinary
| BTbool
| BTint
| BTutc
deriving (Eq, Show)
data DefaultValue
= DefValList
| DefValMaybe
| DefValString T.Text
| DefValBool Bool
| DefValInt Int
| DefValUtc UTCTime
deriving (Eq, Show)
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
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