From 7aea50af90a289084be785ad593b5bb212ba5098 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 17 Jul 2022 21:28:22 +0200 Subject: [PATCH] swagger now works! --- app/AppTypes.hs | 1 + app/Main.hs | 107 +++++++++++++++++++++++++++-------------- mateamt.cabal | 6 +++ src/API.hs | 27 ++++++----- src/Control/Auth.hs | 19 +++++--- src/Control/Avatar.hs | 3 +- src/Control/Journal.hs | 3 +- src/Control/Product.hs | 6 ++- src/Control/Role.hs | 20 +++++--- src/Control/User.hs | 17 ++++--- src/Types/Amount.hs | 6 ++- src/Types/Auth.hs | 20 +++++--- src/Types/Avatar.hs | 3 ++ src/Types/Journal.hs | 7 ++- src/Types/Meta.hs | 2 + src/Types/Product.hs | 7 ++- src/Types/Purchase.hs | 6 ++- src/Types/Role.hs | 6 ++- src/Types/User.hs | 13 ++--- src/Util.hs | 8 +++ 20 files changed, 191 insertions(+), 96 deletions(-) diff --git a/app/AppTypes.hs b/app/AppTypes.hs index 3e914d9..07d9aa4 100644 --- a/app/AppTypes.hs +++ b/app/AppTypes.hs @@ -3,3 +3,4 @@ module AppTypes ) where import AppTypes.Configuration as T +import AppTypes.SwaggerAPI as T diff --git a/app/Main.hs b/app/Main.hs index 9324ce9..04487b4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,13 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} module Main where import Prelude as P import Servant import Servant.Server.Experimental.Auth +import qualified Servant.OpenApi as OA +import Servant.RawM import Data.Set as S (empty) import Data.ByteString.Char8 as B8 hiding (putStrLn) @@ -16,6 +21,9 @@ import Data.String import Data.Yaml import Data.Version (showVersion) import Data.IP +import qualified Data.OpenApi as OA hiding (Server) +import Data.Typeable +import Data.Data (Typeable) import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Migration @@ -32,6 +40,8 @@ import Control.Monad.Reader import Control.Concurrent.STM.TVar +import Control.Lens hiding (Context) + import Options.Applicative import System.Clock (TimeSpec(..)) @@ -153,56 +163,73 @@ main = do app :: ReadState -> Application -- app conn = serveWithContext userApi genAuthServerContext (users conn) app initState = - serveWithContext mateApi (genAuthServerContext (rsConnection initState)) $ + serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) $ hoistServerWithContext - mateApi + combinedAPI authProxy (`runReaderT` initState) - ( authGet :<|> - authSend :<|> - authLogout :<|> + ( mateSwagger :<|> + ( authGet :<|> + authSend :<|> + authLogout :<|> - authManageList :<|> - authManageNewAuth :<|> - authManageDeleteAuth :<|> + authManageList :<|> + authManageNewAuth :<|> + authManageDeleteAuth :<|> - userNew :<|> - userGet :<|> - userUpdate :<|> - userList :<|> - userRecharge :<|> - userTransfer :<|> + userNew :<|> + userGet :<|> + userUpdate :<|> + userList :<|> + userRecharge :<|> + userTransfer :<|> - productNew :<|> - productOverview :<|> - productStockRefill :<|> - productStockUpdate :<|> - productList :<|> - productShortList :<|> + productNew :<|> + productOverview :<|> + productStockRefill :<|> + productStockUpdate :<|> + productList :<|> + productShortList :<|> - buy :<|> + buy :<|> - journalShow :<|> - journalCheck :<|> + journalShow :<|> + journalCheck :<|> - avatarGet :<|> - avatarInsert :<|> - avatarUpdate :<|> - avatarList :<|> + avatarGet :<|> + avatarInsert :<|> + avatarUpdate :<|> + avatarList :<|> - roleList :<|> - roleNew :<|> - roleUpdate :<|> - roleDelete :<|> - roleAssociationList :<|> - roleAssociationSubmit :<|> - roleAssociationDelete :<|> + roleList :<|> + roleNew :<|> + roleUpdate :<|> + roleDelete :<|> + roleAssociationList :<|> + roleAssociationSubmit :<|> + roleAssociationDelete :<|> - metaGet + metaGet + ) ) -mateApi :: Proxy MateAPI -mateApi = Proxy +mateSwagger :: ReaderT ReadState Handler OA.OpenApi +mateSwagger = return $ OA.toOpenApi mateAPI + & OA.info.OA.title .~ "Mateamt API" + & OA.info.OA.version .~ "1.0" + & OA.info.OA.description ?~ "AN API to buy Mate and other products from your local Hackerspace or event." + & OA.info.OA.license ?~ ("AGPL" & OA.url ?~ OA.URL "https://www.gnu.org/licenses/agpl-3.0-standalone.html") + +mateAPI :: Proxy MateAPI +mateAPI = Proxy + +swaggerAPI :: Proxy SwaggerAPI +swaggerAPI = Proxy + +combinedAPI :: Proxy CombinedAPI +combinedAPI = Proxy + +type CombinedAPI = SwaggerAPI :<|> MateAPI authProxy :: Proxy '[ AuthHandler Request (Maybe (Int, AuthMethod)) ] authProxy = Proxy @@ -225,3 +252,9 @@ authHandler conn = mkAuthHandler handler validateToken hh conn _ -> return Nothing + +instance OA.HasOpenApi sub => OA.HasOpenApi (AuthProtect "header-auth" :> sub) where + toOpenApi _ = OA.toOpenApi (Proxy :: Proxy sub) + +instance OA.HasOpenApi (RawM' Application) where + toOpenApi _ = OA.toOpenApi (Proxy :: Proxy (Get '[JSON] NoContent)) diff --git a/mateamt.cabal b/mateamt.cabal index 5216b68..8ad18ea 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -84,6 +84,7 @@ library , bytestring >=0.10.12.0 , base16-bytestring , base64-bytestring + , lens , openapi3 >=3 , random , servant @@ -119,6 +120,7 @@ executable mateamt other-modules: AppTypes AppTypes.Configuration + AppTypes.SwaggerAPI Janitor Paths_mateamt other-extensions: @@ -136,13 +138,17 @@ executable mateamt , containers >=0.6.2.1 , bytestring >=0.10.12.0 , base16-bytestring + , lens , opaleye + , openapi3 , postgresql-simple , postgresql-simple-migration , stm , network , servant , servant-server + , servant-rawm + , servant-openapi3 , warp , wai , wai-logger diff --git a/src/API.hs b/src/API.hs index 805fe09..42820c3 100644 --- a/src/API.hs +++ b/src/API.hs @@ -9,6 +9,7 @@ module API where import Servant.API import Servant.Links +import Servant.Server import Data.Proxy @@ -24,32 +25,32 @@ import Types type MateAPI = "v1" :> ( "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult - :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] () + :<|> "auth" :> AuthProtect "header-auth" :> Delete '[JSON] NoContent :<|> "auth" :> "manage" :> AuthProtect "header-auth" :> Get '[JSON] [AuthOverview] :<|> "auth" :> "manage" :> AuthProtect "header-auth" :> ReqBody '[JSON] AuthSubmit :> Post '[JSON] Int :<|> "auth" :> "manage" :> AuthProtect "header-auth" - :> ReqBody '[JSON] Int :> Delete '[JSON] () + :> ReqBody '[JSON] Int :> Delete '[JSON] NoContent :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int :<|> "user" :> AuthProtect "header-auth" :> Get '[JSON] UserDetails :<|> "user" :> AuthProtect "header-auth" - :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] () + :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] NoContent :<|> "user" :> "list" :> QueryParam "refine" UserRefine :> Get '[JSON] [UserSummary] :<|> "user" :> "recharge" :> AuthProtect "header-auth" - :> ReqBody '[JSON] UserRecharge :> Post '[JSON] () + :> ReqBody '[JSON] UserRecharge :> Post '[JSON] NoContent :<|> "user" :> "transfer" :> AuthProtect "header-auth" - :> ReqBody '[JSON] UserTransfer :> Post '[JSON] () + :> ReqBody '[JSON] UserTransfer :> Post '[JSON] NoContent :<|> "product" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :> Post '[JSON] Int :<|> "product" :> Capture "pid" Int :> Get '[JSON] ProductOverview :<|> "product" :> AuthProtect "header-auth" - :> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] () + :> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] NoContent :<|> "product" :> AuthProtect "header-auth" - :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] () + :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] NoContent :<|> "product" :> "list" :> QueryParam "refine" ProductRefine :> Get '[JSON] [ProductOverview] :<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine @@ -63,13 +64,13 @@ type MateAPI = "v1" :> ( :> Get '[JSON] [JournalEntry] :<|> "journal" :> AuthProtect "header-auth" :> ReqBody '[JSON] JournalCashCheck - :> Post '[JSON] () + :> Post '[JSON] NoContent :<|> "avatar" :> Capture "id" Int :> RawM' Application :<|> "avatar" :> AuthProtect "header-auth" :> ReqBody '[JSON] AvatarData :> Post '[JSON] Int :<|> "avatar" :> AuthProtect "header-auth" :> Capture "id" Int - :> ReqBody '[JSON] AvatarData :> Patch '[JSON] () + :> ReqBody '[JSON] AvatarData :> Patch '[JSON] NoContent :<|> "avatar" :> "list" :> Get '[JSON] [Avatar] :<|> "role" :> "list" @@ -78,17 +79,17 @@ type MateAPI = "v1" :> ( :> Post '[JSON] Int :<|> "role" :> AuthProtect "header-auth" :> Capture "rid" Int :> ReqBody '[JSON] RoleSubmit - :> Patch '[JSON] () + :> Patch '[JSON] NoContent :<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int - :> Delete '[JSON] () + :> Delete '[JSON] NoContent :<|> "role" :> "association" :> "list" :> Get '[JSON] [RoleAssociation] :<|> "role" :> "association" :> AuthProtect "header-auth" :> ReqBody '[JSON] RoleAssociationSubmit - :> Post '[JSON] () + :> Post '[JSON] NoContent :<|> "role" :> "association" :> AuthProtect "header-auth" :> ReqBody '[JSON] RoleAssociation - :> Delete '[JSON] () + :> Delete '[JSON] NoContent :<|> "meta" :> Get '[JSON] MetaInformation ) diff --git a/src/Control/Auth.hs b/src/Control/Auth.hs index d8aa1dc..fda0f45 100644 --- a/src/Control/Auth.hs +++ b/src/Control/Auth.hs @@ -39,9 +39,10 @@ authSend req = uncurry (processAuthRequest req) =<< ((,) <$> authLogout :: Maybe (Int, AuthMethod) - -> MateHandler () -authLogout (Just (muid, _)) = + -> MateHandler NoContent +authLogout (Just (muid, _)) = do processLogout muid =<< asks rsConnection + return NoContent authLogout Nothing = throwError $ err401 { errBody = "Unauthorized access" @@ -93,7 +94,7 @@ authManageNewAuth Nothing _ = authManageDeleteAuth :: Maybe (Int, AuthMethod) -> Int - -> MateHandler () + -> MateHandler NoContent authManageDeleteAuth (Just (uid, method)) adid = if method `elem` [PrimaryPass, ChallengeResponse] then do @@ -102,12 +103,18 @@ authManageDeleteAuth (Just (uid, method)) adid = let currentad = head (filter (\ad -> authOverviewId ad == adid) ads) case authOverviewMethod currentad of PrimaryPass -> if validateDeletion ads - then void (deleteAuthDataById adid conn) + then do + void (deleteAuthDataById adid conn) + return NoContent else throwUnacceptableDeletionError ChallengeResponse -> if validateDeletion ads - then void (deleteAuthDataById adid conn) + then do + void (deleteAuthDataById adid conn) + return NoContent else throwUnacceptableDeletionError - _ -> void $ deleteAuthDataById adid conn + _ -> do + void $ deleteAuthDataById adid conn + return NoContent else throwError $ err401 { errBody = "Unauthorized access" diff --git a/src/Control/Avatar.hs b/src/Control/Avatar.hs index d53504e..4cdc949 100644 --- a/src/Control/Avatar.hs +++ b/src/Control/Avatar.hs @@ -64,10 +64,11 @@ avatarUpdate :: Maybe (Int, AuthMethod) -> Int -> AvatarData - -> MateHandler () + -> MateHandler NoContent avatarUpdate (Just _) aid ad = do conn <- asks rsConnection void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn + return NoContent avatarUpdate Nothing _ _ = throwError $ err401 { errBody = "No Authentication present." diff --git a/src/Control/Journal.hs b/src/Control/Journal.hs index 1d925f8..c958f4f 100644 --- a/src/Control/Journal.hs +++ b/src/Control/Journal.hs @@ -35,13 +35,14 @@ journalShow Nothing _ _ = journalCheck :: Maybe (Int, AuthMethod) -> JournalCashCheck - -> MateHandler () + -> MateHandler NoContent journalCheck (Just (uid, method)) check = do mayCheckJournal <- checkCapability uid roleCanManageJournal if method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal then do conn <- asks rsConnection void $ insertNewCashCheck check conn + return NoContent else throwError $ err401 { errBody = "Wrong Authentication present" diff --git a/src/Control/Product.hs b/src/Control/Product.hs index 7b94adb..a1f4078 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -48,7 +48,7 @@ productOverview pid = do productStockRefill :: Maybe (Int, AuthMethod) -> [AmountRefill] - -> MateHandler () + -> MateHandler NoContent productStockRefill (Just (uid, auth)) amorefs = do mayRefill <- anyM (checkCapability uid) @@ -71,6 +71,7 @@ productStockRefill (Just (uid, auth)) amorefs = do amorefs then do void $ manualProductAmountRefill amorefs conn + return NoContent else throwError $ err400 { errBody = "Amounts less than 0 are not acceptable." @@ -91,7 +92,7 @@ productStockRefill Nothing _ = productStockUpdate :: Maybe (Int, AuthMethod) -> [AmountUpdate] - -> MateHandler () + -> MateHandler NoContent productStockUpdate (Just (uid, method)) amoups = do mayUpdateStock <- checkCapability uid roleCanManageProducts if method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock @@ -100,6 +101,7 @@ productStockUpdate (Just (uid, method)) amoups = do then do conn <- asks rsConnection void $ manualProductAmountUpdate amoups conn + return NoContent else throwError $ err400 { errBody = "Amounts less than 0 are not acceptable." diff --git a/src/Control/Role.hs b/src/Control/Role.hs index e0fb968..2f047e7 100644 --- a/src/Control/Role.hs +++ b/src/Control/Role.hs @@ -41,12 +41,13 @@ roleUpdate :: Maybe (Int, AuthMethod) -> Int -> RoleSubmit - -> MateHandler () + -> MateHandler NoContent roleUpdate (Just (uid, auth)) id_ roleSubmit = do isRoleManager <- checkCapability uid roleCanManageRoles if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager - then + then do void $ updateRole id_ roleSubmit =<< asks rsConnection + return NoContent else throwError $ err401 { errBody = "You are not authorized for this action." @@ -59,12 +60,13 @@ roleUpdate Nothing _ _ = roleDelete :: Maybe (Int, AuthMethod) -> Int - -> MateHandler () + -> MateHandler NoContent roleDelete (Just (uid, auth)) id_ = do isRoleManager <- checkCapability uid roleCanManageRoles if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager - then + then do void $ deleteRole id_ =<< asks rsConnection + return NoContent else throwError $ err401 { errBody = "You are not authorized for this action." @@ -82,12 +84,13 @@ roleAssociationList = roleAssociationSubmit :: Maybe (Int, AuthMethod) -> RoleAssociationSubmit - -> MateHandler () + -> MateHandler NoContent roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do isRoleManager <- checkCapability uid roleCanManageRoles if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager - then + then do associateUserToRole auid arid =<< asks rsConnection + return NoContent else throwError $ err401 { errBody = "You are not authorized for this action." @@ -100,12 +103,13 @@ roleAssociationSubmit Nothing _ = roleAssociationDelete :: Maybe (Int, AuthMethod) -> RoleAssociation - -> MateHandler () + -> MateHandler NoContent roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do isRoleManager <- checkCapability uid roleCanManageRoles if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager - then + then do void $ deleteAssociation auid arid =<< asks rsConnection + return NoContent else throwError $ err401 { errBody = "You are not authorized for this action." diff --git a/src/Control/User.hs b/src/Control/User.hs index 292d9f9..84cc58a 100644 --- a/src/Control/User.hs +++ b/src/Control/User.hs @@ -78,7 +78,7 @@ userGetAll (Just (_, _)) = do userUpdate :: Maybe (Int, AuthMethod) -> UserDetailsSubmit - -> MateHandler () + -> MateHandler NoContent userUpdate Nothing _ = throwError $ err401 { errBody = "No Authentication present." @@ -89,6 +89,7 @@ userUpdate (Just (aid, method)) uds = now <- liftIO getCurrentTime conn <- asks rsConnection void $ updateUserDetails aid uds (utctDay now) conn + return NoContent else throwError $ err401 { errBody = "Wrong Authentication present." @@ -96,11 +97,12 @@ userUpdate (Just (aid, method)) uds = userUpdateTimestamp :: Maybe (Int, AuthMethod) - -> MateHandler () + -> MateHandler NoContent userUpdateTimestamp (Just (aid, _)) = do now <- liftIO getCurrentTime conn <- asks rsConnection void $ updateUserTimestamp aid (utctDay now) conn + return NoContent userUpdateTimestamp Nothing = throwError $ err401 { errBody = "No Authentication present." @@ -116,7 +118,7 @@ userList ref = do userRecharge :: Maybe (Int, AuthMethod) -> UserRecharge - -> MateHandler () + -> MateHandler NoContent userRecharge (Just (auid, _)) (UserRecharge amount) = do when (amount < 0) $ throwError $ err400 @@ -132,6 +134,7 @@ userRecharge (Just (auid, _)) (UserRecharge amount) = do ) conn void $ addToUserBalance auid amount conn + return NoContent userRecharge Nothing _ = throwError $ err401 { errBody = "No Authentication present." @@ -140,7 +143,7 @@ userRecharge Nothing _ = userTransfer :: Maybe (Int, AuthMethod) -> UserTransfer - -> MateHandler () + -> MateHandler NoContent userTransfer (Just (auid, method)) (UserTransfer target amount) = do when (amount < 0) $ throwError $ err400 @@ -167,6 +170,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do } void $ addToUserBalance auid (-amount) conn void $ addToUserBalance target amount conn + return NoContent userTransfer Nothing _ = throwError $ err401 { errBody = "No Authentication present." @@ -176,7 +180,7 @@ userNotify :: Maybe (Int, AuthMethod) -> [PurchaseDetail] -> PurchaseResult - -> MateHandler () + -> MateHandler NoContent userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do conn <- asks rsConnection authOV <- selectAuthOverviewById auid conn @@ -240,8 +244,9 @@ userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do userDetails (__ "Purchase notification") messageText + return NoContent Nothing -> - return () + return NoContent userNotify Nothing _ _ = throwError $ err401 { errBody = "No Authentication present." diff --git a/src/Types/Amount.hs b/src/Types/Amount.hs index 8b164ba..efc4ceb 100644 --- a/src/Types/Amount.hs +++ b/src/Types/Amount.hs @@ -4,8 +4,10 @@ module Types.Amount where import GHC.Generics + import Data.Aeson +import Data.OpenApi import Data.Time (UTCTime) -- internal imports @@ -22,7 +24,7 @@ instance ToJSON AmountUpdate where toEncoding = genericToEncoding defaultOptions instance FromJSON AmountUpdate - +instance ToSchema AmountUpdate data AmountRefill = AmountRefill { amountRefillProductId :: Int @@ -35,7 +37,7 @@ instance ToJSON AmountRefill where toEncoding = genericToEncoding defaultOptions instance FromJSON AmountRefill - +instance ToSchema AmountRefill data Amount = Amount { amountProductId :: Int diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 5b946ce..561c160 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -13,6 +13,8 @@ import Data.Time.Clock (UTCTime) import Data.ByteString (ByteString) +import Data.OpenApi + import qualified Data.Text as T import Data.Text.Encoding @@ -32,7 +34,7 @@ instance ToJSON TicketRequest where toEncoding = genericToEncoding defaultOptions instance FromJSON TicketRequest - +instance ToSchema TicketRequest data AuthInfo = AuthInfo { authChallenge :: Maybe T.Text @@ -44,6 +46,7 @@ instance ToJSON AuthInfo where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthInfo +instance ToSchema AuthInfo -- instance ToDatabase AuthInfo where -- @@ -71,6 +74,8 @@ instance ToJSON AuthMethod where instance FromJSON AuthMethod +instance ToSchema AuthMethod +instance ToParamSchema AuthMethod data AuthSubmit = AuthSubmit { authSubmitMethod :: AuthMethod @@ -83,7 +88,7 @@ instance ToJSON AuthSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthSubmit - +instance ToSchema AuthSubmit newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord) @@ -91,7 +96,7 @@ instance ToJSON AuthTicket where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthTicket - +instance ToSchema AuthTicket newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic) @@ -99,7 +104,7 @@ instance ToJSON AuthResponse where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthResponse - +instance ToSchema AuthResponse data AuthRequest = AuthRequest { authRequestTicket :: AuthTicket @@ -111,7 +116,7 @@ instance ToJSON AuthRequest where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthRequest - +instance ToSchema AuthRequest data AuthResult = Granted @@ -124,7 +129,7 @@ instance ToJSON AuthResult where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthResult - +instance ToSchema AuthResult newtype AuthToken = AuthToken T.Text deriving (Show, Generic) @@ -132,7 +137,7 @@ instance ToJSON AuthToken where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthToken - +instance ToSchema AuthToken data Token = Token { tokenString :: T.Text @@ -209,6 +214,7 @@ instance ToJSON AuthOverview where toEncoding = genericToEncoding defaultOptions instance FromJSON AuthOverview +instance ToSchema AuthOverview -- instance ToDatabase AuthOverview where -- diff --git a/src/Types/Avatar.hs b/src/Types/Avatar.hs index cb39b49..e7fc4bc 100644 --- a/src/Types/Avatar.hs +++ b/src/Types/Avatar.hs @@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Word (Word8) import Data.Aeson +import Data.OpenApi (ToSchema) import GHC.Generics @@ -28,6 +29,7 @@ instance ToJSON Avatar where toEncoding = genericToEncoding defaultOptions instance FromJSON Avatar +instance ToSchema Avatar instance FromDatabase Avatar where type OutTuple Avatar = (Int, T.Text, ByteString, ByteString) @@ -46,6 +48,7 @@ instance ToJSON AvatarData where toEncoding = genericToEncoding defaultOptions instance FromJSON AvatarData +instance ToSchema AvatarData instance FromDatabase AvatarData where type OutTuple AvatarData = (T.Text, ByteString) diff --git a/src/Types/Journal.hs b/src/Types/Journal.hs index 2f55383..8fa4045 100644 --- a/src/Types/Journal.hs +++ b/src/Types/Journal.hs @@ -7,6 +7,7 @@ import GHC.Generics import Data.Aeson import Data.Time (UTCTime) +import Data.OpenApi (ToSchema) data JournalEntry = JournalEntry { journalEntryId :: Int @@ -23,7 +24,7 @@ instance ToJSON JournalEntry where toEncoding = genericToEncoding defaultOptions instance FromJSON JournalEntry - +instance ToSchema JournalEntry data JournalSubmit = JournalSubmit { journalSubmitUser :: Maybe Int @@ -36,7 +37,7 @@ instance ToJSON JournalSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON JournalSubmit - +instance ToSchema JournalSubmit data JournalCashCheck = JournalCashCheck { journalCashCheckUser :: Int @@ -48,6 +49,7 @@ instance ToJSON JournalCashCheck where toEncoding = genericToEncoding defaultOptions instance FromJSON JournalCashCheck +instance ToSchema JournalCashCheck data JournalAction = CashCheck @@ -61,3 +63,4 @@ instance ToJSON JournalAction where toEncoding = genericToEncoding defaultOptions instance FromJSON JournalAction +instance ToSchema JournalAction diff --git a/src/Types/Meta.hs b/src/Types/Meta.hs index 4b51c5f..f0216b6 100644 --- a/src/Types/Meta.hs +++ b/src/Types/Meta.hs @@ -6,6 +6,7 @@ import qualified Data.Text as T import Data.Aeson import GHC.Generics +import Data.OpenApi (ToSchema) data MetaInformation = MetaInformation { metaInfoVersion :: T.Text @@ -18,3 +19,4 @@ instance ToJSON MetaInformation where toEncoding = genericToEncoding defaultOptions instance FromJSON MetaInformation +instance ToSchema MetaInformation diff --git a/src/Types/Product.hs b/src/Types/Product.hs index d7f1631..bad5b89 100644 --- a/src/Types/Product.hs +++ b/src/Types/Product.hs @@ -5,6 +5,7 @@ module Types.Product where import GHC.Generics import Data.Aeson +import Data.OpenApi (ToSchema) import qualified Data.Text as T @@ -33,6 +34,7 @@ instance ToJSON Product where toEncoding = genericToEncoding defaultOptions instance FromJSON Product +instance ToSchema Product instance ToDatabase Product where @@ -72,7 +74,7 @@ instance ToJSON ProductOverview where toEncoding = genericToEncoding defaultOptions instance FromJSON ProductOverview - +instance ToSchema ProductOverview data ProductShortOverview = ProductShortOverview { productShortOverviewId :: Int @@ -94,7 +96,7 @@ instance ToJSON ProductShortOverview where toEncoding = genericToEncoding defaultOptions instance FromJSON ProductShortOverview - +instance ToSchema ProductShortOverview data ProductSubmit = ProductSubmit { productSubmitIdent :: T.Text @@ -116,3 +118,4 @@ instance ToJSON ProductSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON ProductSubmit +instance ToSchema ProductSubmit diff --git a/src/Types/Purchase.hs b/src/Types/Purchase.hs index a4d6c89..2f4b50c 100644 --- a/src/Types/Purchase.hs +++ b/src/Types/Purchase.hs @@ -5,6 +5,7 @@ module Types.Purchase where import Data.Aeson import GHC.Generics +import Data.OpenApi (ToSchema) data PurchaseDetail = PurchaseDetail @@ -17,7 +18,7 @@ instance ToJSON PurchaseDetail where toEncoding = genericToEncoding defaultOptions instance FromJSON PurchaseDetail - +instance ToSchema PurchaseDetail data PurchaseResult = PurchaseResult { purchaseResultFlag :: PurchaseResultFlag @@ -29,7 +30,7 @@ instance ToJSON PurchaseResult where toEncoding = genericToEncoding defaultOptions instance FromJSON PurchaseResult - +instance ToSchema PurchaseResult data PurchaseResultFlag = PurchaseOK @@ -41,3 +42,4 @@ instance ToJSON PurchaseResultFlag where toEncoding = genericToEncoding defaultOptions instance FromJSON PurchaseResultFlag +instance ToSchema PurchaseResultFlag diff --git a/src/Types/Role.hs b/src/Types/Role.hs index 04aa83e..399d7e2 100644 --- a/src/Types/Role.hs +++ b/src/Types/Role.hs @@ -4,7 +4,7 @@ module Types.Role where import qualified Data.Text as T import Data.Aeson - +import Data.OpenApi (ToSchema) import GHC.Generics -- internal imports @@ -35,6 +35,7 @@ instance ToJSON Role where toEncoding = genericToEncoding defaultOptions instance FromJSON Role +instance ToSchema Role instance ToDatabase Role where @@ -71,6 +72,7 @@ instance ToJSON RoleSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON RoleSubmit +instance ToSchema RoleSubmit data RoleAssociation = RoleAssociation { roleAssociationUser :: Int @@ -82,6 +84,7 @@ instance ToJSON RoleAssociation where toEncoding = genericToEncoding defaultOptions instance FromJSON RoleAssociation +instance ToSchema RoleAssociation data RoleAssociationSubmit = RoleAssociationSubmit { roleAssociationSubmitUser :: Int @@ -93,3 +96,4 @@ instance ToJSON RoleAssociationSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON RoleAssociationSubmit +instance ToSchema RoleAssociationSubmit diff --git a/src/Types/User.hs b/src/Types/User.hs index 2f4ead7..ebf9675 100644 --- a/src/Types/User.hs +++ b/src/Types/User.hs @@ -5,8 +5,8 @@ module Types.User where import GHC.Generics import Data.Time.Calendar (Day) - import Data.Aeson +import Data.OpenApi (ToSchema) import qualified Data.Text as T @@ -54,7 +54,7 @@ instance ToJSON UserSummary where toEncoding = genericToEncoding defaultOptions instance FromJSON UserSummary - +instance ToSchema UserSummary data UserSubmit = UserSubmit { userSubmitIdent :: T.Text @@ -67,7 +67,7 @@ instance ToJSON UserSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON UserSubmit - +instance ToSchema UserSubmit data UserDetails = UserDetails { userDetailsId :: Int @@ -84,7 +84,7 @@ instance ToJSON UserDetails where toEncoding = genericToEncoding defaultOptions instance FromJSON UserDetails - +instance ToSchema UserDetails data UserDetailsSubmit = UserDetailsSubmit { userDetailsSubmitIdent :: T.Text @@ -99,7 +99,7 @@ instance ToJSON UserDetailsSubmit where toEncoding = genericToEncoding defaultOptions instance FromJSON UserDetailsSubmit - +instance ToSchema UserDetailsSubmit newtype UserRecharge = UserRecharge { userRechargeAmount :: Int @@ -110,7 +110,7 @@ instance ToJSON UserRecharge where toEncoding = genericToEncoding defaultOptions instance FromJSON UserRecharge - +instance ToSchema UserRecharge data UserTransfer = UserTransfer { userTransferTarget :: Int @@ -122,3 +122,4 @@ instance ToJSON UserTransfer where toEncoding = genericToEncoding defaultOptions instance FromJSON UserTransfer +instance ToSchema UserTransfer diff --git a/src/Util.hs b/src/Util.hs index 4d02b72..7970543 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -155,3 +155,11 @@ sendNotification mail = do else print ("Warning: sending notification failed: Sendmail not present!" :: String) + +err200 :: ServerError +err200 = ServerError + { errHTTPCode = 200 + , errBody = "OK" + , errReasonPhrase = "RequestScceeded" + , errHeaders = [] + }