battleplace 0.1.0.9 → 0.1.0.10

raw patch · 9 files changed

+501/−502 lines, 9 filesdep +swagger2dep +template-haskellPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: swagger2, template-haskell

API changes (from Hackage documentation)

Files

• BattlePlace/Rating.hs +10/−4
• BattlePlace/Skill/Glicko/Types.hs +18/−18
• BattlePlace/Token/Types.hs +15/−6
• BattlePlace/Util.hs +50/−15
• BattlePlace/WebApi.hs +116/−177
• BattlePlace/WebApi/Auth.hs +8/−8
• BattlePlace/WebApi/Types.hs +194/−272
• BattlePlace/WebApi/Types/Util.hs +85/−0
• battleplace.cabal +5/−2

@@ -4,13 +4,19 @@ License: MIT -} -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}  module BattlePlace.Rating-	( Rating(..)-	) where+  ( Rating(..)+  ) where  import qualified Data.Aeson as J+import qualified Data.Swagger as SW+import GHC.Generics(Generic) +import BattlePlace.Util+ -- | User rating.-newtype Rating = Rating Double deriving (Eq, Ord, J.FromJSON, J.ToJSON)+newtype Rating = Rating Double deriving (Eq, Ord, Generic, J.FromJSON, J.ToJSON)+instance SW.ToSchema Rating where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema

@@ -7,9 +7,9 @@ {-# LANGUAGE DeriveGeneric #-}  module BattlePlace.Skill.Glicko.Types-	( Skill(..)-	, ratingFromSkill-	) where+  ( Skill(..)+  , ratingFromSkill+  ) where  import qualified Data.Aeson as J import Data.Default@@ -19,28 +19,28 @@ import BattlePlace.Util  data Skill = Skill-	{ skill_rating :: {-# UNPACK #-} !Double-	, skill_deviation :: {-# UNPACK #-} !Double-	, skill_volatility :: {-# UNPACK #-} !Double-	} deriving Generic+  { skill_rating :: {-# UNPACK #-} !Double+  , skill_deviation :: {-# UNPACK #-} !Double+  , skill_volatility :: {-# UNPACK #-} !Double+  } deriving Generic  -- default skill instance Default (Skill) where-	def = Skill-		{ skill_rating = 1500-		, skill_deviation = 350-		, skill_volatility = 0.06-		}+  def = Skill+    { skill_rating = 1500+    , skill_deviation = 350+    , skill_volatility = 0.06+    }  instance J.FromJSON (Skill) where-	parseJSON = J.genericParseJSON jsonOptions+  parseJSON = J.genericParseJSON jsonOptions instance J.ToJSON (Skill) where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  toJSON = J.genericToJSON jsonOptions+  toEncoding = J.genericToEncoding jsonOptions  -- | Conservative rating for skill. ratingFromSkill :: Skill -> Rating ratingFromSkill Skill-	{ skill_rating = rating-	, skill_deviation = deviation-	} = Rating $ rating - deviation * 2+  { skill_rating = rating+  , skill_deviation = deviation+  } = Rating $ rating - deviation * 2

@@ -4,21 +4,30 @@ License: MIT -} -{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-}  module BattlePlace.Token.Types-	( InternalToken(..)-	, Ticket(..)-	) where+  ( InternalToken(..)+  , Ticket(..)+  ) where  import qualified Data.Aeson as J+import qualified Data.Swagger as SW import qualified Data.Text as T+import GHC.Generics(Generic) import Servant.API +import BattlePlace.Util+ -- | Internal token. -- Token is encrypted, and contains some internal information.-newtype InternalToken a = InternalToken T.Text deriving (J.FromJSON, J.ToJSON, FromHttpApiData, ToHttpApiData)+newtype InternalToken a = InternalToken T.Text deriving (Generic, J.FromJSON, J.ToJSON, FromHttpApiData, ToHttpApiData)+instance SW.ToSchema (InternalToken a) where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema+instance SW.ToParamSchema (InternalToken a)  -- | Ticket. -- Ticket doesn't contain information, it's just an ID.-newtype Ticket = Ticket T.Text deriving (J.FromJSON, J.ToJSON)+newtype Ticket = Ticket T.Text deriving (Generic, J.FromJSON, J.ToJSON)+instance SW.ToSchema Ticket where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema

@@ -4,31 +4,66 @@ License: MIT -} -{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE LambdaCase, TemplateHaskell #-}  module BattlePlace.Util-	( jsonOptions-	, jsonOptionsWithTag-	) where+  ( jsonOptions+  , jsonOptionsWithTag+  , swaggerSchemaOptions+  , declareStruct+  ) where +import Control.Monad import qualified Data.Aeson as J+import qualified Data.Swagger as SW+import GHC.Generics(Generic)+import Language.Haskell.TH  jsonOptions :: J.Options jsonOptions = jsonOptionsWithTag "status"  jsonOptionsWithTag :: String -> J.Options jsonOptionsWithTag tag = J.defaultOptions-	{ J.fieldLabelModifier = dropBeforeUnderscore-	, J.constructorTagModifier = dropBeforeUnderscore-	, J.sumEncoding = J.TaggedObject-		{ J.tagFieldName = tag-		, J.contentsFieldName = "contents"-		}-	}+  { J.fieldLabelModifier = dropBeforeUnderscore+  , J.constructorTagModifier = dropBeforeUnderscore+  , J.sumEncoding = J.TaggedObject+    { J.tagFieldName = tag+    , J.contentsFieldName = "contents"+    }+  } +swaggerSchemaOptions :: SW.SchemaOptions+swaggerSchemaOptions = SW.defaultSchemaOptions+  { SW.fieldLabelModifier = dropBeforeUnderscore+  , SW.constructorTagModifier = dropBeforeUnderscore+  }+ dropBeforeUnderscore :: String -> String dropBeforeUnderscore = \case-	x : xs -> case x of-		'_' -> xs-		_ -> dropBeforeUnderscore xs-	[] -> []+  x : xs -> case x of+    '_' -> xs+    _ -> dropBeforeUnderscore xs+  [] -> []++declareStruct :: [Name] -> Q [Dec]+declareStruct names = fmap concat . forM names $ \t -> sequence+  [ standaloneDerivD (pure []) [t| Generic $(conT t) |]+  , instanceD (pure []) [t| J.FromJSON $(conT t) |]+    [ funD 'J.parseJSON+      [ clause [] (normalB [| J.genericParseJSON jsonOptions |]) []+      ]+    ]+  , instanceD (pure []) [t| J.ToJSON $(conT t) |]+    [ funD 'J.toJSON+      [ clause [] (normalB [| J.genericToJSON jsonOptions |]) []+      ]+    , funD 'J.toEncoding+      [ clause [] (normalB [| J.genericToEncoding jsonOptions |]) []+      ]+    ]+  , instanceD (pure []) [t| SW.ToSchema $(conT t) |]+    [ funD 'SW.declareNamedSchema+      [ clause [] (normalB [| SW.genericDeclareNamedSchemaUnrestricted swaggerSchemaOptions |]) []+      ]+    ]+  ]

@@ -4,30 +4,28 @@ License: MIT -} -{-# LANGUAGE DataKinds, DeriveGeneric, GeneralizedNewtypeDeriving, TypeOperators #-}+{-# LANGUAGE DataKinds, DeriveGeneric, GeneralizedNewtypeDeriving, StandaloneDeriving, TemplateHaskell, TypeOperators #-}  module BattlePlace.WebApi-	( WebApi-	, ClientAuthRequest(..)-	, ClientAuthResponse(..)-	, MatchRequest(..)-	, MatchResponse(..)-	, MatchStatusResponse(..)-	, SessionResultRequest(..)-	, ServerMatchRequest(..)-	, ServerMatchResponse(..)-	, ServerMatchCancelRequest(..)-	, ServerMatchCancelResponse(..)-	, ServerMatchSessionsRequest(..)-	, ServerMatchSessionsResponse(..)-	, ServerSessionResultRequest(..)-	) where+  ( WebApi+  , ClientAuthRequest(..)+  , ClientAuthResponse(..)+  , MatchRequest(..)+  , MatchResponse(..)+  , MatchStatusResponse(..)+  , SessionResultRequest(..)+  , ServerMatchRequest(..)+  , ServerMatchResponse(..)+  , ServerMatchCancelRequest(..)+  , ServerMatchCancelResponse(..)+  , ServerMatchSessionsRequest(..)+  , ServerMatchSessionsResponse(..)+  , ServerSessionResultRequest(..)+  ) where -import qualified Data.Aeson as J import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU-import GHC.Generics(Generic) import Servant.API  import BattlePlace.Token.Types@@ -36,190 +34,131 @@ import BattlePlace.WebApi.Types  type WebApi = "v1a" :>-	(    "client" :>-		(    "auth" :> ReqBody '[JSON] ClientAuthRequest :> Post '[JSON] ClientAuthResponse-		:<|> "match" :>-			(    AuthProtect ClientToken :> ReqBody '[JSON] MatchRequest :> Post '[JSON] MatchResponse-			:<|> AuthProtect ClientToken :> Capture "matchToken" (InternalToken MatchToken) :> Get '[JSON] MatchStatusResponse-			:<|> AuthProtect ClientToken :> Capture "matchToken" (InternalToken MatchToken) :> Delete '[JSON] ()-			)-		:<|> "session" :> Capture "sessionToken" (InternalToken SessionToken) :>-			(    "result" :> AuthProtect ClientToken :> ReqBody '[JSON] SessionResultRequest :> Post '[JSON] ()-			)-		:<|> "info" :>-			(    "stats" :> AuthProtect ClientToken :> Get '[JSON] UserStats-			)-		)-	:<|> "server" :>-		(    "match" :>-			(    ReqBody '[JSON] ServerMatchRequest :> Post '[JSON] ServerMatchResponse-			:<|> ReqBody '[JSON] ServerMatchCancelRequest :> Delete '[JSON] ServerMatchCancelResponse-			:<|> "sessions" :> ReqBody '[JSON] ServerMatchSessionsRequest :> Post '[JSON] ServerMatchSessionsResponse-			)-		:<|> "session" :> Capture "serverSessionToken" (InternalToken ServerSessionToken) :>-			(    "result" :> ReqBody '[JSON] ServerSessionResultRequest :> Post '[JSON] ()-			)-		)-	)+  (    "client" :>+    (    "auth" :> ReqBody '[JSON] ClientAuthRequest :> Post '[JSON] ClientAuthResponse+    :<|> "match" :>+      (    AuthProtect ClientToken :> ReqBody '[JSON] MatchRequest :> Post '[JSON] MatchResponse+      :<|> AuthProtect ClientToken :> Capture "matchToken" (InternalToken MatchToken) :> Get '[JSON] MatchStatusResponse+      :<|> AuthProtect ClientToken :> Capture "matchToken" (InternalToken MatchToken) :> Delete '[JSON] ()+      )+    :<|> "session" :> Capture "sessionToken" (InternalToken SessionToken) :>+      (    "result" :> AuthProtect ClientToken :> ReqBody '[JSON] SessionResultRequest :> Post '[JSON] ()+      )+    :<|> "info" :>+      (    "stats" :> AuthProtect ClientToken :> Get '[JSON] UserStats+      )+    )+  :<|> "server" :>+    (    "match" :>+      (    ReqBody '[JSON] ServerMatchRequest :> Post '[JSON] ServerMatchResponse+      :<|> ReqBody '[JSON] ServerMatchCancelRequest :> Delete '[JSON] ServerMatchCancelResponse+      :<|> "sessions" :> ReqBody '[JSON] ServerMatchSessionsRequest :> Post '[JSON] ServerMatchSessionsResponse+      )+    :<|> "session" :> Capture "serverSessionToken" (InternalToken ServerSessionToken) :>+      (    "result" :> ReqBody '[JSON] ServerSessionResultRequest :> Post '[JSON] ()+      )+    )+  )  data ClientAuthRequest = ClientAuthRequest-	{ clientAuthRequest_projectId :: {-# UNPACK #-} !ProjectId-	, clientAuthRequest_auth :: !Auth-	} deriving Generic-instance J.FromJSON ClientAuthRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ClientAuthRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { clientAuthRequest_projectId :: {-# UNPACK #-} !ProjectId+  , clientAuthRequest_auth :: !Auth+  }  data ClientAuthResponse-	= ClientAuthResponse_authenticated-		{ clientAuthResponse_clientToken :: !(InternalToken ClientToken)-		, clientAuthResponse_name :: !T.Text-		, clientAuthResponse_pictureUrl :: !T.Text-		}-	| ClientAuthResponse_notAuthenticated-		{ clientAuthResponse_error :: !T.Text-		}-	deriving Generic-instance J.FromJSON ClientAuthResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ClientAuthResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = ClientAuthResponse_authenticated+    { clientAuthResponse_clientToken :: !(InternalToken ClientToken)+    , clientAuthResponse_name :: !T.Text+    , clientAuthResponse_pictureUrl :: !T.Text+    }+  | ClientAuthResponse_notAuthenticated+    { clientAuthResponse_error :: !T.Text+    }  data MatchRequest = MatchRequest-	{ matchRequest_teamSizes :: !(VU.Vector MatchTeamSize)-	, matchRequest_maxMatchTime :: {-# UNPACK #-} !Int-	, matchRequest_matchTag :: !(Maybe MatchTag)-	, matchRequest_serverTag :: !(Maybe ServerTag)-	, matchRequest_info :: !(Maybe MatchPlayerInfo)-	} deriving Generic-instance J.FromJSON MatchRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { matchRequest_teamSizes :: !(VU.Vector MatchTeamSize)+  , matchRequest_maxMatchTime :: {-# UNPACK #-} !Int+  , matchRequest_matchTag :: !(Maybe MatchTag)+  , matchRequest_serverTag :: !(Maybe ServerTag)+  , matchRequest_info :: !(Maybe MatchPlayerInfo)+  }  data MatchResponse = MatchResponse-	{ matchResponse_matchToken :: !(InternalToken MatchToken)-	} deriving Generic-instance J.FromJSON MatchResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { matchResponse_matchToken :: !(InternalToken MatchToken)+  }  data MatchStatusResponse-	= MatchStatusResponse_notFound-	| MatchStatusResponse_inProgress-	| MatchStatusResponse_matched-		{ matchStatusResponse_session :: !MatchSession-		}-	| MatchStatusResponse_failed-		{ matchStatusResponse_reason :: !MatchFailureReason-		}-	deriving Generic-instance J.FromJSON MatchStatusResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchStatusResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = MatchStatusResponse_notFound+  | MatchStatusResponse_inProgress+  | MatchStatusResponse_matched+    { matchStatusResponse_session :: !MatchSession+    }+  | MatchStatusResponse_failed+    { matchStatusResponse_reason :: !MatchFailureReason+    }  data SessionResultRequest-	= SessionResultRequest_finished-		{ sessionResultRequest_ranks :: !(V.Vector Int)-		}-	| SessionResultRequest_cancelled-	deriving Generic-instance J.FromJSON SessionResultRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON SessionResultRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = SessionResultRequest_finished+    { sessionResultRequest_ranks :: !(V.Vector Int)+    }+  | SessionResultRequest_cancelled  data ClientDataRequest = ClientDataRequest-	{ clientDataRequest_after :: !(Maybe T.Text)-	} deriving Generic-instance J.FromJSON ClientDataRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ClientDataRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { clientDataRequest_after :: !(Maybe T.Text)+  }  data ServerMatchRequest = ServerMatchRequest-	{ serverMatchRequest_projectId :: {-# UNPACK #-} !ProjectId-	, serverMatchRequest_projectServerToken :: !ProjectServerToken-	, serverMatchRequest_serverTag :: !(Maybe ServerTag)-	, serverMatchRequest_name :: !ProjectServerName-	, serverMatchRequest_info :: !(Maybe MatchServerInfo)-	, serverMatchRequest_timeout :: !(Maybe Int)-	} deriving Generic-instance J.FromJSON ServerMatchRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { serverMatchRequest_projectId :: {-# UNPACK #-} !ProjectId+  , serverMatchRequest_projectServerToken :: !ProjectServerToken+  , serverMatchRequest_serverTag :: !(Maybe ServerTag)+  , serverMatchRequest_name :: !ProjectServerName+  , serverMatchRequest_info :: !(Maybe MatchServerInfo)+  , serverMatchRequest_timeout :: !(Maybe Int)+  }  data ServerMatchResponse-	= ServerMatchResponse_registered-	| ServerMatchResponse_unused-	deriving Generic-instance J.FromJSON ServerMatchResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = ServerMatchResponse_registered+  | ServerMatchResponse_unused  data ServerMatchCancelRequest = ServerMatchCancelRequest-	{ serverMatchCancelRequest_projectId :: {-# UNPACK #-} !ProjectId-	, serverMatchCancelRequest_projectServerToken :: !ProjectServerToken-	, serverMatchCancelRequest_name :: !ProjectServerName-	} deriving Generic-instance J.FromJSON ServerMatchCancelRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchCancelRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { serverMatchCancelRequest_projectId :: {-# UNPACK #-} !ProjectId+  , serverMatchCancelRequest_projectServerToken :: !ProjectServerToken+  , serverMatchCancelRequest_name :: !ProjectServerName+  }  data ServerMatchCancelResponse-	= ServerMatchCancelResponse_cancelled-	| ServerMatchCancelResponse_unused-	deriving Generic-instance J.FromJSON ServerMatchCancelResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchCancelResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = ServerMatchCancelResponse_cancelled+  | ServerMatchCancelResponse_unused  data ServerMatchSessionsRequest = ServerMatchSessionsRequest-	{ serverMatchSessionsRequest_projectId :: {-# UNPACK #-} !ProjectId-	, serverMatchSessionsRequest_projectServerToken :: !ProjectServerToken-	, serverMatchSessionsRequest_name :: !ProjectServerName-	} deriving Generic-instance J.FromJSON ServerMatchSessionsRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchSessionsRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { serverMatchSessionsRequest_projectId :: {-# UNPACK #-} !ProjectId+  , serverMatchSessionsRequest_projectServerToken :: !ProjectServerToken+  , serverMatchSessionsRequest_name :: !ProjectServerName+  }  data ServerMatchSessionsResponse = ServerMatchSessionsResponse-	{ serverMatchSessionsResponse_sessions :: !(V.Vector MatchServerSession)-	} deriving Generic-instance J.FromJSON ServerMatchSessionsResponse where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerMatchSessionsResponse where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { serverMatchSessionsResponse_sessions :: !(V.Vector MatchServerSession)+  }  data ServerSessionResultRequest-	= ServerSessionResultRequest_finished-		{ serverSessionResultRequest_ranks :: !(V.Vector Int)-		}-	| ServerSessionResultRequest_cancelled-	deriving Generic-instance J.FromJSON ServerSessionResultRequest where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerSessionResultRequest where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = ServerSessionResultRequest_finished+    { serverSessionResultRequest_ranks :: !(V.Vector Int)+    }+  | ServerSessionResultRequest_cancelled++declareStruct+  [ ''ClientAuthRequest+  , ''ClientAuthResponse+  , ''MatchRequest+  , ''MatchResponse+  , ''MatchStatusResponse+  , ''SessionResultRequest+  , ''ClientDataRequest+  , ''ServerMatchRequest+  , ''ServerMatchResponse+  , ''ServerMatchCancelRequest+  , ''ServerMatchCancelResponse+  , ''ServerMatchSessionsRequest+  , ''ServerMatchSessionsResponse+  , ''ServerSessionResultRequest+  ]

@@ -7,8 +7,8 @@ {-# LANGUAGE DeriveGeneric #-}  module BattlePlace.WebApi.Auth-	( ClientToken(..)-	) where+  ( ClientToken(..)+  ) where  import qualified Data.Aeson as J import GHC.Generics(Generic)@@ -17,11 +17,11 @@ import BattlePlace.WebApi.Types  data ClientToken = ClientToken-	{ clientToken_projectId :: {-# UNPACK #-} !ProjectId-	, clientToken_client :: !Client-	} deriving Generic+  { clientToken_projectId :: {-# UNPACK #-} !ProjectId+  , clientToken_client :: !Client+  } deriving Generic instance J.FromJSON ClientToken where-	parseJSON = J.genericParseJSON jsonOptions+  parseJSON = J.genericParseJSON jsonOptions instance J.ToJSON ClientToken where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  toJSON = J.genericToJSON jsonOptions+  toEncoding = J.genericToEncoding jsonOptions

@@ -4,363 +4,285 @@ License: MIT -} -{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, LambdaCase, ViewPatterns #-}+{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, LambdaCase, OverloadedStrings, StandaloneDeriving, TemplateHaskell, ViewPatterns #-}  module BattlePlace.WebApi.Types-	( AccountId(..)-	, ProjectId(..)-	, Auth(..)-	, AuthType(..)-	, authTypeOf-	, Client(..)-	, ClientType(..)-	, clientTypeOf-	, ProjectServerId(..)-	, ProjectServerToken(..)-	, ProjectServerName(..)-	, MatchTeamSize-	, MatchTag(..)-	, ServerTag(..)-	, MatchPlayerInfo(..)-	, MatchServerInfo(..)-	, MatchToken(..)-	, MatchFailureReason(..)-	, SessionToken(..)-	, SessionId(..)-	, ServerSessionToken(..)-	, ExternalSessionId(..)-	, MatchSession(..)-	, MatchServerSession(..)-	, MatchTeam(..)-	, MatchPlayer(..)-	, MatchServer(..)-	, UserStats(..)-	, Identified(..)-	, Base64ByteString(..)-	, Base64Word64(..)-	, StrWord64(..)-	) where+  ( ProjectId(..)+  , Auth(..)+  , AuthType(..)+  , authTypeOf+  , Client(..)+  , ClientType(..)+  , clientTypeOf+  , DeveloperId(..)+  , ProjectServerId(..)+  , ProjectServerToken(..)+  , ProjectServerName(..)+  , MatchTeamSize+  , MatchTag(..)+  , ServerTag(..)+  , MatchPlayerInfo(..)+  , MatchServerInfo(..)+  , MatchToken(..)+  , MatchFailureReason(..)+  , SessionToken(..)+  , SessionId(..)+  , ServerSessionToken(..)+  , ExternalSessionId(..)+  , MatchSession(..)+  , MatchServerSession(..)+  , MatchTeam(..)+  , MatchPlayer(..)+  , MatchServer(..)+  , UserStats(..)+  , Identified(..)+  , Base64ByteString(..)+  , Base64Word64(..)+  , StrWord64(..)+  ) where -import Control.Monad import qualified Data.Aeson as J-import qualified Data.Aeson.Types as J-import qualified Data.ByteArray as BA-import qualified Data.ByteArray.Encoding as BA-import qualified Data.ByteString as B-import Data.Either import Data.Hashable-import qualified Data.Serialize as S-import Data.String+import Data.Proxy+import qualified Data.Swagger as SW import qualified Data.Text as T-import qualified Data.Text.Encoding as T import qualified Data.Vector as V-import Data.Word-import Foreign.Storable import GHC.Generics(Generic) import Servant.API  import BattlePlace.Rating import BattlePlace.Token.Types import BattlePlace.Util---- | Account id.--- At the moment it's just itch user id, but that may change.-newtype AccountId = AccountId Base64Word64 deriving (J.FromJSON, J.ToJSON, FromHttpApiData)+import BattlePlace.WebApi.Types.Util  -- | Project id.-newtype ProjectId = ProjectId Base64Word64 deriving (Eq, Hashable, J.FromJSON, J.ToJSON, FromHttpApiData)+newtype ProjectId = ProjectId Base64Word64 deriving (Eq, Generic, Hashable, J.FromJSON, J.ToJSON, FromHttpApiData)+instance SW.ToSchema ProjectId where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  data Auth-	= Auth_itchJwtToken-		{ auth_itchJwtToken :: !T.Text-		}-	| Auth_itchApiKey-		{ auth_itchApiKey :: !T.Text-		}-	| Auth_steamEncryptedTicket-		{ auth_steamEncryptedTicket :: !T.Text-		}-	| Auth_testKey-		{ auth_testKey :: !T.Text-		, auth_testId :: !StrWord64-		}-	deriving Generic+  = Auth_itchJwtToken+    { auth_itchJwtToken :: !T.Text+    }+  | Auth_itchApiKey+    { auth_itchApiKey :: !T.Text+    }+  | Auth_steamEncryptedTicket+    { auth_steamEncryptedTicket :: !T.Text+    }+  | Auth_testKey+    { auth_testKey :: !T.Text+    , auth_testId :: !StrWord64+    }+  deriving Generic instance J.FromJSON Auth where-	parseJSON = J.genericParseJSON jsonOptions-		{ J.sumEncoding = J.UntaggedValue-		}+  parseJSON = J.genericParseJSON jsonOptions+    { J.sumEncoding = J.UntaggedValue+    } instance J.ToJSON Auth where-	toJSON = J.genericToJSON jsonOptions-		{ J.sumEncoding = J.UntaggedValue-		}-	toEncoding = J.genericToEncoding jsonOptions-		{ J.sumEncoding = J.UntaggedValue-		}+  toJSON = J.genericToJSON jsonOptions+    { J.sumEncoding = J.UntaggedValue+    }+  toEncoding = J.genericToEncoding jsonOptions+    { J.sumEncoding = J.UntaggedValue+    }+instance SW.ToSchema Auth where+  declareNamedSchema = SW.genericDeclareNamedSchemaUnrestricted swaggerSchemaOptions  -- | Auth type (for logging). data AuthType-	= AuthType_itchJwtToken-	| AuthType_itchApiKey-	| AuthType_steamEncryptedTicket-	| AuthType_testKey-	deriving (Eq, Generic)-instance Hashable AuthType-instance J.FromJSON AuthType where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON AuthType where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  = AuthType_itchJwtToken+  | AuthType_itchApiKey+  | AuthType_steamEncryptedTicket+  | AuthType_testKey+  deriving Eq  authTypeOf :: Auth -> AuthType authTypeOf = \case-	Auth_itchJwtToken {} -> AuthType_itchJwtToken-	Auth_itchApiKey {} -> AuthType_itchApiKey-	Auth_steamEncryptedTicket {} -> AuthType_steamEncryptedTicket-	Auth_testKey {} -> AuthType_testKey+  Auth_itchJwtToken {} -> AuthType_itchJwtToken+  Auth_itchApiKey {} -> AuthType_itchApiKey+  Auth_steamEncryptedTicket {} -> AuthType_steamEncryptedTicket+  Auth_testKey {} -> AuthType_testKey  data Client-	= Client_itch-		{ client_itchUserId :: {-# UNPACK #-} !StrWord64-		}-	| Client_steam-		{ client_steamId :: {-# UNPACK #-} !StrWord64-		}-	| Client_test-		{ client_testId :: {-# UNPACK #-} !StrWord64-		}-	deriving (Eq, Generic)+  = Client_itch+    { client_itchUserId :: {-# UNPACK #-} !StrWord64+    }+  | Client_steam+    { client_steamId :: {-# UNPACK #-} !StrWord64+    }+  | Client_test+    { client_testId :: {-# UNPACK #-} !StrWord64+    }+  deriving (Eq, Generic) instance Hashable Client instance J.FromJSON Client where-	parseJSON = J.genericParseJSON $ jsonOptionsWithTag "type"+  parseJSON = J.genericParseJSON $ jsonOptionsWithTag "type" instance J.ToJSON Client where-	toJSON = J.genericToJSON $ jsonOptionsWithTag "type"-	toEncoding = J.genericToEncoding $ jsonOptionsWithTag "type"+  toJSON = J.genericToJSON $ jsonOptionsWithTag "type"+  toEncoding = J.genericToEncoding $ jsonOptionsWithTag "type"  -- | Type of the client. Must correspont to JSON field "type" of 'Client'. data ClientType-	= ClientType_itch-	| ClientType_steam-	| ClientType_test-	deriving (Eq, Generic)+  = ClientType_itch+  | ClientType_steam+  | ClientType_test+  deriving Eq instance Hashable ClientType-instance J.FromJSON ClientType where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ClientType where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions  clientTypeOf :: Client -> ClientType clientTypeOf = \case-	Client_itch {} -> ClientType_itch-	Client_steam {} -> ClientType_steam-	Client_test {} -> ClientType_test+  Client_itch {} -> ClientType_itch+  Client_steam {} -> ClientType_steam+  Client_test {} -> ClientType_test +-- | Developer id.+-- At the moment it's just itch user id, but that may change.+newtype DeveloperId = DeveloperId Base64Word64 deriving (J.FromJSON, J.ToJSON, FromHttpApiData)+ -- | Project's server id. newtype ProjectServerId = ProjectServerId Base64Word64 deriving (Eq, Hashable, J.FromJSON, J.FromJSONKey, J.ToJSON, J.ToJSONKey)  -- | Project's secret server token.-newtype ProjectServerToken = ProjectServerToken T.Text deriving (Eq, Hashable, J.FromJSON, J.ToJSON)+newtype ProjectServerToken = ProjectServerToken T.Text deriving (Eq, Generic, Hashable, J.FromJSON, J.ToJSON)+instance SW.ToSchema ProjectServerToken where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | Project's server name.-newtype ProjectServerName = ProjectServerName T.Text deriving (Eq, Hashable, J.FromJSON, J.ToJSON)+newtype ProjectServerName = ProjectServerName T.Text deriving (Eq, Generic, Hashable, J.FromJSON, J.ToJSON)+instance SW.ToSchema ProjectServerName where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | Size of a team in match request. type MatchTeamSize = Int  -- | Match tag in match request.-newtype MatchTag = MatchTag T.Text deriving (Eq, Hashable, Semigroup, Monoid, J.FromJSON, J.ToJSON)+newtype MatchTag = MatchTag T.Text deriving (Eq, Generic, Hashable, Semigroup, Monoid, J.FromJSON, J.ToJSON)+instance SW.ToSchema MatchTag where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | Server tag in match request.-newtype ServerTag = ServerTag T.Text deriving (Eq, Hashable, Semigroup, Monoid, J.FromJSON, J.ToJSON)+newtype ServerTag = ServerTag T.Text deriving (Eq, Generic, Hashable, Semigroup, Monoid, J.FromJSON, J.ToJSON)+instance SW.ToSchema ServerTag where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | Opaque player info.-newtype MatchPlayerInfo = MatchPlayerInfo J.Value deriving (J.FromJSON, J.ToJSON)+newtype MatchPlayerInfo = MatchPlayerInfo J.Value deriving (Generic, J.FromJSON, J.ToJSON)+instance SW.ToSchema MatchPlayerInfo where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions $ \_ -> SW.declareSchema (Proxy :: Proxy J.Object)  -- | Opaque server info.-newtype MatchServerInfo = MatchServerInfo J.Value deriving (J.FromJSON, J.ToJSON)+newtype MatchServerInfo = MatchServerInfo J.Value deriving (Generic, J.FromJSON, J.ToJSON)+instance SW.ToSchema MatchServerInfo where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions $ \_ -> SW.declareSchema (Proxy :: Proxy J.Object)  -- | Match token. data MatchToken = MatchToken-	{-	} deriving Generic-instance J.FromJSON MatchToken where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchToken where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  {+  }  -- | Reason of match failure. data MatchFailureReason-	-- | Failed to make a match in a specified time.-	= MatchFailureReason_timedOut-	-- | Match was made, but no server is available (and use of server is mandatory).-	| MatchFailureReason_noServer-	-- | Matching was explicitly cancelled by user.-	| MatchFailureReason_cancelled-	deriving Generic-instance J.FromJSON MatchFailureReason where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchFailureReason where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  -- | Failed to make a match in a specified time.+  = MatchFailureReason_timedOut+  -- | Match was made, but no server is available (and use of server is mandatory).+  | MatchFailureReason_noServer+  -- | Matching was explicitly cancelled by user.+  | MatchFailureReason_cancelled  -- | Session token. data SessionToken = SessionToken-	{ sessionToken_sessionId :: !SessionId-	, sessionToken_teamIndex :: {-# UNPACK #-} !Int-	, sessionToken_mateIndex :: {-# UNPACK #-} !Int-	} deriving Generic-instance J.FromJSON SessionToken where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON SessionToken where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { sessionToken_sessionId :: !SessionId+  , sessionToken_teamIndex :: {-# UNPACK #-} !Int+  , sessionToken_mateIndex :: {-# UNPACK #-} !Int+  }  -- | Session id.-newtype SessionId = SessionId Base64ByteString deriving (Eq, Hashable, J.FromJSON, J.ToJSON)+newtype SessionId = SessionId Base64ByteString deriving (Eq, Generic, Hashable, J.FromJSON, J.ToJSON)+instance SW.ToSchema SessionId where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | Server session token. newtype ServerSessionToken = ServerSessionToken-	{ serverSessionToken_sessionId :: SessionId-	} deriving Generic-instance J.FromJSON ServerSessionToken where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON ServerSessionToken where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { serverSessionToken_sessionId :: SessionId+  }  -- | External session token for exposure to clients and servers.-newtype ExternalSessionId = ExternalSessionId T.Text deriving (Eq, Hashable, J.FromJSON, J.ToJSON)+newtype ExternalSessionId = ExternalSessionId T.Text deriving (Eq, Generic, Hashable, J.FromJSON, J.ToJSON)+instance SW.ToSchema ExternalSessionId where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema +-- | Match player.+data MatchPlayer = MatchPlayer+  { matchPlayer_info :: !MatchPlayerInfo+  , matchPlayer_ourTicket :: !(Maybe Ticket)+  , matchPlayer_theirTicket :: !(Maybe Ticket)+  }++-- | Match server.+data MatchServer = MatchServer+  { matchServer_info :: !MatchServerInfo+  , matchServer_ourTicket :: !Ticket+  , matchServer_theirTicket :: !Ticket+  }++declareStruct+  [ ''AuthType+  , ''ClientType+  , ''MatchToken+  , ''MatchFailureReason+  , ''SessionToken+  , ''ServerSessionToken+  , ''MatchPlayer+  , ''MatchServer+  ]++instance Hashable AuthType+ -- | Match session. data MatchSession = MatchSession-	{ matchSession_externalSessionId :: !ExternalSessionId-	, matchSession_sessionToken :: !(InternalToken SessionToken)-	, matchSession_teams :: !(V.Vector MatchTeam)-	, matchSession_teamIndex :: {-# UNPACK #-} !Int-	, matchSession_mateIndex :: {-# UNPACK #-} !Int-	, matchSession_server :: !(Maybe MatchServer)-	} deriving Generic-instance J.FromJSON MatchSession where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchSession where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { matchSession_externalSessionId :: !ExternalSessionId+  , matchSession_sessionToken :: !(InternalToken SessionToken)+  , matchSession_teams :: !(V.Vector MatchTeam)+  , matchSession_teamIndex :: {-# UNPACK #-} !Int+  , matchSession_mateIndex :: {-# UNPACK #-} !Int+  , matchSession_server :: !(Maybe MatchServer)+  }  -- | Match server session. data MatchServerSession = MatchServerSession-	{ matchServerSession_externalSessionId :: !ExternalSessionId-	, matchServerSession_serverSessionToken :: !(InternalToken ServerSessionToken)-	, matchServerSession_teams :: !(V.Vector MatchTeam)-	, matchServerSession_matchTag :: !MatchTag-	, matchServerSession_serverTag :: !ServerTag-	} deriving Generic-instance J.FromJSON MatchServerSession where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchServerSession where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { matchServerSession_externalSessionId :: !ExternalSessionId+  , matchServerSession_serverSessionToken :: !(InternalToken ServerSessionToken)+  , matchServerSession_teams :: !(V.Vector MatchTeam)+  , matchServerSession_matchTag :: !MatchTag+  , matchServerSession_serverTag :: !ServerTag+  }  -- | Match team.-newtype MatchTeam = MatchTeam (V.Vector MatchPlayer) deriving (J.FromJSON, J.ToJSON)---- | Match player.-data MatchPlayer = MatchPlayer-	{ matchPlayer_info :: !MatchPlayerInfo-	, matchPlayer_ourTicket :: !(Maybe Ticket)-	, matchPlayer_theirTicket :: !(Maybe Ticket)-	} deriving Generic-instance J.FromJSON MatchPlayer where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchPlayer where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions---- | Match server.-data MatchServer = MatchServer-	{ matchServer_info :: !MatchServerInfo-	, matchServer_ourTicket :: !Ticket-	, matchServer_theirTicket :: !Ticket-	} deriving Generic-instance J.FromJSON MatchServer where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON MatchServer where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+newtype MatchTeam = MatchTeam (V.Vector MatchPlayer) deriving (Generic, J.FromJSON, J.ToJSON)+instance SW.ToSchema MatchTeam where+  declareNamedSchema = SW.genericDeclareNamedSchemaNewtype swaggerSchemaOptions SW.declareSchema  -- | User stats. data UserStats = UserStats-	{ userStats_rank :: {-# UNPACK #-} !Int-	, userStats_rating :: {-# UNPACK #-} !Rating-	} deriving Generic-instance J.FromJSON UserStats where-	parseJSON = J.genericParseJSON jsonOptions-instance J.ToJSON UserStats where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions+  { userStats_rank :: {-# UNPACK #-} !Int+  , userStats_rating :: {-# UNPACK #-} !Rating+  }  -- | Generic data type for id + object. data Identified i a = Identified-	{ identified_id :: !i-	, identified_info :: !a-	} deriving Generic+  { identified_id :: !i+  , identified_info :: !a+  } deriving Generic instance (J.FromJSON i, J.FromJSON a) => J.FromJSON (Identified i a) where-	parseJSON = J.genericParseJSON jsonOptions+  parseJSON = J.genericParseJSON jsonOptions instance (J.ToJSON i, J.ToJSON a) => J.ToJSON (Identified i a) where-	toJSON = J.genericToJSON jsonOptions-	toEncoding = J.genericToEncoding jsonOptions---- | Implementation for parseJson using base64-serialized string.-base64ParseJsonStr :: S.Serialize a => T.Text -> J.Parser a-base64ParseJsonStr = \case-	(BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8 -> Right (S.decode -> Right object)) -> return object-	_ -> fail "wrong base64 object"---- | Implementation for toJson using base64-serialized string.-base64ToJsonStr :: S.Serialize a => a -> T.Text-base64ToJsonStr = T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded . S.encode---- | Implementation for parseUrlPiece using base64-serialized string.-base64ParseUrlPiece :: S.Serialize a => T.Text -> Either T.Text a-base64ParseUrlPiece = either (Left . T.pack) (either (Left . T.pack) Right . S.decode) . BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8---- | ByteString which serializes to JSON as base64 string.-newtype Base64ByteString = Base64ByteString B.ByteString deriving (Eq, Ord, Semigroup, Monoid, Hashable, BA.ByteArray, BA.ByteArrayAccess)-instance J.FromJSON Base64ByteString where-	parseJSON = either fail return . BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8 <=< J.parseJSON-instance J.ToJSON Base64ByteString where-	toJSON = J.toJSON . T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded-	toEncoding = J.toEncoding . T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded---- | Word64 which serializes to JSON as base64 string.--- Useful because 64-bit integer is not representable in javascript.-newtype Base64Word64 = Base64Word64 Word64 deriving (Eq, Ord, Num, Storable, Hashable, S.Serialize, Read, Show)-instance J.FromJSON Base64Word64 where-	parseJSON = base64ParseJsonStr <=< J.parseJSON-instance J.FromJSONKey Base64Word64 where-	fromJSONKey = J.FromJSONKeyTextParser base64ParseJsonStr-instance J.ToJSON Base64Word64 where-	toJSON = J.toJSON . base64ToJsonStr-	toEncoding = J.toEncoding . base64ToJsonStr-instance J.ToJSONKey Base64Word64 where-	toJSONKey = J.toJSONKeyText base64ToJsonStr-instance FromHttpApiData Base64Word64 where-	parseUrlPiece = base64ParseUrlPiece-instance IsString Base64Word64 where-	fromString = fromRight (error "wrong base64 word") . J.parseEither J.parseJSON . J.String . T.pack+  toJSON = J.genericToJSON jsonOptions+  toEncoding = J.genericToEncoding jsonOptions+instance (SW.ToSchema i, SW.ToSchema a) => SW.ToSchema (Identified i a) --- | Word64 which serializes to JSON as decimal string.--- Useful because 64-bit integer is not representable in javascript.-newtype StrWord64 = StrWord64 Word64 deriving (Eq, Ord, Num, Storable, Hashable, S.Serialize, Read, Show)-instance J.FromJSON StrWord64 where-	parseJSON = f . reads <=< J.parseJSON where-		f = \case-			[(n, "")] -> return $ StrWord64 n-			_ -> fail "wrong number"-instance J.ToJSON StrWord64 where-	toJSON (StrWord64 n) = J.toJSON $ show n-instance FromHttpApiData StrWord64 where-	parseUrlPiece = f . reads <=< parseUrlPiece where-		f = \case-			[(n, "")] -> return $ StrWord64 n-			_ -> fail "wrong number"+declareStruct+  [ ''MatchSession+  , ''MatchServerSession+  , ''UserStats+  ]

@@ -0,0 +1,85 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, LambdaCase, OverloadedStrings, ViewPatterns #-}++module BattlePlace.WebApi.Types.Util+  ( Base64ByteString(..)+  , Base64Word64(..)+  , StrWord64(..)+  ) where++import Control.Monad+import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import qualified Data.ByteArray as BA+import qualified Data.ByteArray.Encoding as BA+import qualified Data.ByteString as B+import Data.Either+import Data.Hashable+import qualified Data.Serialize as S+import Data.String+import qualified Data.Swagger as SW+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Word+import Foreign.Storable+import Servant.API++-- | Implementation for parseJson using base64-serialized string.+base64ParseJsonStr :: S.Serialize a => T.Text -> J.Parser a+base64ParseJsonStr = \case+  (BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8 -> Right (S.decode -> Right object)) -> return object+  _ -> fail "wrong base64 object"++-- | Implementation for toJson using base64-serialized string.+base64ToJsonStr :: S.Serialize a => a -> T.Text+base64ToJsonStr = T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded . S.encode++-- | Implementation for parseUrlPiece using base64-serialized string.+base64ParseUrlPiece :: S.Serialize a => T.Text -> Either T.Text a+base64ParseUrlPiece = either (Left . T.pack) (either (Left . T.pack) Right . S.decode) . BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8++-- | ByteString which serializes to JSON as base64 string.+newtype Base64ByteString = Base64ByteString B.ByteString deriving (Eq, Ord, Semigroup, Monoid, Hashable, BA.ByteArray, BA.ByteArrayAccess)+instance J.FromJSON Base64ByteString where+  parseJSON = either fail return . BA.convertFromBase BA.Base64URLUnpadded . T.encodeUtf8 <=< J.parseJSON+instance J.ToJSON Base64ByteString where+  toJSON = J.toJSON . T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded+  toEncoding = J.toEncoding . T.decodeUtf8 . BA.convertToBase BA.Base64URLUnpadded+instance SW.ToSchema Base64ByteString where+  declareNamedSchema _ = return $ SW.NamedSchema (Just "Base64ByteString") SW.byteSchema++-- | Word64 which serializes to JSON as base64 string.+-- Useful because 64-bit integer is not representable in javascript.+newtype Base64Word64 = Base64Word64 Word64 deriving (Eq, Ord, Num, Storable, Hashable, S.Serialize, Read, Show)+instance J.FromJSON Base64Word64 where+  parseJSON = base64ParseJsonStr <=< J.parseJSON+instance J.FromJSONKey Base64Word64 where+  fromJSONKey = J.FromJSONKeyTextParser base64ParseJsonStr+instance J.ToJSON Base64Word64 where+  toJSON = J.toJSON . base64ToJsonStr+  toEncoding = J.toEncoding . base64ToJsonStr+instance J.ToJSONKey Base64Word64 where+  toJSONKey = J.toJSONKeyText base64ToJsonStr+instance FromHttpApiData Base64Word64 where+  parseUrlPiece = base64ParseUrlPiece+instance IsString Base64Word64 where+  fromString = fromRight (error "wrong base64 word") . J.parseEither J.parseJSON . J.String . T.pack+instance SW.ToSchema Base64Word64 where+  declareNamedSchema _ = return $ SW.NamedSchema (Just "Base64Word64") SW.byteSchema++-- | Word64 which serializes to JSON as decimal string.+-- Useful because 64-bit integer is not representable in javascript.+newtype StrWord64 = StrWord64 Word64 deriving (Eq, Ord, Num, Storable, Hashable, S.Serialize, Read, Show)+instance J.FromJSON StrWord64 where+  parseJSON = f . reads <=< J.parseJSON where+    f = \case+      [(n, "")] -> return $ StrWord64 n+      _ -> fail "wrong number"+instance J.ToJSON StrWord64 where+  toJSON (StrWord64 n) = J.toJSON $ show n+instance FromHttpApiData StrWord64 where+  parseUrlPiece = f . reads <=< parseUrlPiece where+    f = \case+      [(n, "")] -> Right $ StrWord64 n+      _ -> Left "wrong number"+instance SW.ToSchema StrWord64 where+  declareNamedSchema _ = return $ SW.NamedSchema (Just "StrWord64") SW.byteSchema

@@ -1,5 +1,5 @@ name:                battleplace-version:             0.1.0.9+version:             0.1.0.10 synopsis:            Core definitions for BattlePlace.io service description:         Core definitions for BattlePlace.io service license:             MIT@@ -21,6 +21,7 @@     BattlePlace.WebApi     BattlePlace.WebApi.Auth     BattlePlace.WebApi.Types+    BattlePlace.WebApi.Types.Util   other-modules:   build-depends:     aeson@@ -31,7 +32,9 @@     , hashable     , memory     , servant+    , swagger2+    , template-haskell     , text     , vector-  ghc-options:         -Wall -Wno-tabs+  ghc-options:         -Wall   default-language:    Haskell2010