swagger now works!

2022-07-17 21:28:22 +02:00 · 2022-07-17 21:28:22 +02:00 · 7aea50af90
commit 7aea50af90
parent f3891f2bfe
20 changed files with 191 additions and 96 deletions
--- 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
--- 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))
--- 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
--- 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
  )
--- 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"
--- 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."
--- 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"
--- 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."
--- 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."
--- 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."
--- 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
--- 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
 -- 
--- 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)
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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
--- 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 = []
+  }