swagger now works!

app/AppTypes.hs

@@ -3,3 +3,4 @@ module AppTypes
   ) where
 
 import AppTypes.Configuration as T
+import AppTypes.SwaggerAPI as T

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,11 +163,12 @@ 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)
+      ( mateSwagger :<|>
         ( authGet :<|>
           authSend :<|>
           authLogout :<|>
@@ -200,9 +211,25 @@ app initState =
 
           metaGet
         )
+      )
 
-mateApi :: Proxy MateAPI
+mateSwagger :: ReaderT ReadState Handler OA.OpenApi
-mateApi = Proxy
+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))

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

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
   )

src/Control/Auth.hs

@@ -39,9 +39,10 @@ authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
 
 authLogout
   :: Maybe (Int, AuthMethod)
-  -> MateHandler ()
+  -> MateHandler NoContent
-authLogout (Just (muid, _)) =
+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"

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."

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"

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."

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."

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."

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

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
 -- 

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)

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

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

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

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

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

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

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 = []
+  }