swagger now works!

This commit is contained in:
nek0 2022-07-17 21:28:22 +02:00
parent f3891f2bfe
commit 7aea50af90
20 changed files with 191 additions and 96 deletions

View file

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

View file

@ -1,13 +1,18 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main where module Main where
import Prelude as P import Prelude as P
import Servant import Servant
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
import qualified Servant.OpenApi as OA
import Servant.RawM
import Data.Set as S (empty) import Data.Set as S (empty)
import Data.ByteString.Char8 as B8 hiding (putStrLn) import Data.ByteString.Char8 as B8 hiding (putStrLn)
@ -16,6 +21,9 @@ import Data.String
import Data.Yaml import Data.Yaml
import Data.Version (showVersion) import Data.Version (showVersion)
import Data.IP 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
import Database.PostgreSQL.Simple.Migration import Database.PostgreSQL.Simple.Migration
@ -32,6 +40,8 @@ import Control.Monad.Reader
import Control.Concurrent.STM.TVar import Control.Concurrent.STM.TVar
import Control.Lens hiding (Context)
import Options.Applicative import Options.Applicative
import System.Clock (TimeSpec(..)) import System.Clock (TimeSpec(..))
@ -153,11 +163,12 @@ main = do
app :: ReadState -> Application app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn) -- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = app initState =
serveWithContext mateApi (genAuthServerContext (rsConnection initState)) $ serveWithContext combinedAPI (genAuthServerContext (rsConnection initState)) $
hoistServerWithContext hoistServerWithContext
mateApi combinedAPI
authProxy authProxy
(`runReaderT` initState) (`runReaderT` initState)
( mateSwagger :<|>
( authGet :<|> ( authGet :<|>
authSend :<|> authSend :<|>
authLogout :<|> authLogout :<|>
@ -200,9 +211,25 @@ app initState =
metaGet 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 '[ AuthHandler Request (Maybe (Int, AuthMethod)) ]
authProxy = Proxy authProxy = Proxy
@ -225,3 +252,9 @@ authHandler conn = mkAuthHandler handler
validateToken hh conn validateToken hh conn
_ -> _ ->
return Nothing 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))

View file

@ -84,6 +84,7 @@ library
, bytestring >=0.10.12.0 , bytestring >=0.10.12.0
, base16-bytestring , base16-bytestring
, base64-bytestring , base64-bytestring
, lens
, openapi3 >=3 , openapi3 >=3
, random , random
, servant , servant
@ -119,6 +120,7 @@ executable mateamt
other-modules: other-modules:
AppTypes AppTypes
AppTypes.Configuration AppTypes.Configuration
AppTypes.SwaggerAPI
Janitor Janitor
Paths_mateamt Paths_mateamt
other-extensions: other-extensions:
@ -136,13 +138,17 @@ executable mateamt
, containers >=0.6.2.1 , containers >=0.6.2.1
, bytestring >=0.10.12.0 , bytestring >=0.10.12.0
, base16-bytestring , base16-bytestring
, lens
, opaleye , opaleye
, openapi3
, postgresql-simple , postgresql-simple
, postgresql-simple-migration , postgresql-simple-migration
, stm , stm
, network , network
, servant , servant
, servant-server , servant-server
, servant-rawm
, servant-openapi3
, warp , warp
, wai , wai
, wai-logger , wai-logger

View file

@ -9,6 +9,7 @@ module API where
import Servant.API import Servant.API
import Servant.Links import Servant.Links
import Servant.Server
import Data.Proxy import Data.Proxy
@ -24,32 +25,32 @@ import Types
type MateAPI = "v1" :> ( type MateAPI = "v1" :> (
"auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo "auth" :> "get" :> ReqBody '[JSON] TicketRequest :> Post '[JSON] AuthInfo
:<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult :<|> "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" :<|> "auth" :> "manage" :> AuthProtect "header-auth"
:> Get '[JSON] [AuthOverview] :> Get '[JSON] [AuthOverview]
:<|> "auth" :> "manage" :> AuthProtect "header-auth" :<|> "auth" :> "manage" :> AuthProtect "header-auth"
:> ReqBody '[JSON] AuthSubmit :> Post '[JSON] Int :> ReqBody '[JSON] AuthSubmit :> Post '[JSON] Int
:<|> "auth" :> "manage" :> AuthProtect "header-auth" :<|> "auth" :> "manage" :> AuthProtect "header-auth"
:> ReqBody '[JSON] Int :> Delete '[JSON] () :> ReqBody '[JSON] Int :> Delete '[JSON] NoContent
:<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
:<|> "user" :> AuthProtect "header-auth" :> Get '[JSON] UserDetails :<|> "user" :> AuthProtect "header-auth" :> Get '[JSON] UserDetails
:<|> "user" :> AuthProtect "header-auth" :<|> "user" :> AuthProtect "header-auth"
:> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] () :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] NoContent
:<|> "user" :> "list" :> QueryParam "refine" UserRefine :> Get '[JSON] [UserSummary] :<|> "user" :> "list" :> QueryParam "refine" UserRefine :> Get '[JSON] [UserSummary]
:<|> "user" :> "recharge" :> AuthProtect "header-auth" :<|> "user" :> "recharge" :> AuthProtect "header-auth"
:> ReqBody '[JSON] UserRecharge :> Post '[JSON] () :> ReqBody '[JSON] UserRecharge :> Post '[JSON] NoContent
:<|> "user" :> "transfer" :> AuthProtect "header-auth" :<|> "user" :> "transfer" :> AuthProtect "header-auth"
:> ReqBody '[JSON] UserTransfer :> Post '[JSON] () :> ReqBody '[JSON] UserTransfer :> Post '[JSON] NoContent
:<|> "product" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :<|> "product" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
:> Post '[JSON] Int :> Post '[JSON] Int
:<|> "product" :> Capture "pid" Int :> Get '[JSON] ProductOverview :<|> "product" :> Capture "pid" Int :> Get '[JSON] ProductOverview
:<|> "product" :> AuthProtect "header-auth" :<|> "product" :> AuthProtect "header-auth"
:> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] () :> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] NoContent
:<|> "product" :> AuthProtect "header-auth" :<|> "product" :> AuthProtect "header-auth"
:> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] () :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] NoContent
:<|> "product" :> "list" :> QueryParam "refine" ProductRefine :<|> "product" :> "list" :> QueryParam "refine" ProductRefine
:> Get '[JSON] [ProductOverview] :> Get '[JSON] [ProductOverview]
:<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine :<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine
@ -63,13 +64,13 @@ type MateAPI = "v1" :> (
:> Get '[JSON] [JournalEntry] :> Get '[JSON] [JournalEntry]
:<|> "journal" :> AuthProtect "header-auth" :<|> "journal" :> AuthProtect "header-auth"
:> ReqBody '[JSON] JournalCashCheck :> ReqBody '[JSON] JournalCashCheck
:> Post '[JSON] () :> Post '[JSON] NoContent
:<|> "avatar" :> Capture "id" Int :> RawM' Application :<|> "avatar" :> Capture "id" Int :> RawM' Application
:<|> "avatar" :> AuthProtect "header-auth" :> ReqBody '[JSON] AvatarData :<|> "avatar" :> AuthProtect "header-auth" :> ReqBody '[JSON] AvatarData
:> Post '[JSON] Int :> Post '[JSON] Int
:<|> "avatar" :> AuthProtect "header-auth" :> Capture "id" Int :<|> "avatar" :> AuthProtect "header-auth" :> Capture "id" Int
:> ReqBody '[JSON] AvatarData :> Patch '[JSON] () :> ReqBody '[JSON] AvatarData :> Patch '[JSON] NoContent
:<|> "avatar" :> "list" :> Get '[JSON] [Avatar] :<|> "avatar" :> "list" :> Get '[JSON] [Avatar]
:<|> "role" :> "list" :<|> "role" :> "list"
@ -78,17 +79,17 @@ type MateAPI = "v1" :> (
:> Post '[JSON] Int :> Post '[JSON] Int
:<|> "role" :> AuthProtect "header-auth" :> Capture "rid" Int :<|> "role" :> AuthProtect "header-auth" :> Capture "rid" Int
:> ReqBody '[JSON] RoleSubmit :> ReqBody '[JSON] RoleSubmit
:> Patch '[JSON] () :> Patch '[JSON] NoContent
:<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int :<|> "role" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
:> Delete '[JSON] () :> Delete '[JSON] NoContent
:<|> "role" :> "association" :> "list" :<|> "role" :> "association" :> "list"
:> Get '[JSON] [RoleAssociation] :> Get '[JSON] [RoleAssociation]
:<|> "role" :> "association" :> AuthProtect "header-auth" :<|> "role" :> "association" :> AuthProtect "header-auth"
:> ReqBody '[JSON] RoleAssociationSubmit :> ReqBody '[JSON] RoleAssociationSubmit
:> Post '[JSON] () :> Post '[JSON] NoContent
:<|> "role" :> "association" :> AuthProtect "header-auth" :<|> "role" :> "association" :> AuthProtect "header-auth"
:> ReqBody '[JSON] RoleAssociation :> ReqBody '[JSON] RoleAssociation
:> Delete '[JSON] () :> Delete '[JSON] NoContent
:<|> "meta" :> Get '[JSON] MetaInformation :<|> "meta" :> Get '[JSON] MetaInformation
) )

View file

@ -39,9 +39,10 @@ authSend req = uncurry (processAuthRequest req) =<< ((,) <$>
authLogout authLogout
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> MateHandler () -> MateHandler NoContent
authLogout (Just (muid, _)) = authLogout (Just (muid, _)) = do
processLogout muid =<< asks rsConnection processLogout muid =<< asks rsConnection
return NoContent
authLogout Nothing = authLogout Nothing =
throwError $ err401 throwError $ err401
{ errBody = "Unauthorized access" { errBody = "Unauthorized access"
@ -93,7 +94,7 @@ authManageNewAuth Nothing _ =
authManageDeleteAuth authManageDeleteAuth
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> Int -> Int
-> MateHandler () -> MateHandler NoContent
authManageDeleteAuth (Just (uid, method)) adid = authManageDeleteAuth (Just (uid, method)) adid =
if method `elem` [PrimaryPass, ChallengeResponse] if method `elem` [PrimaryPass, ChallengeResponse]
then do then do
@ -102,12 +103,18 @@ authManageDeleteAuth (Just (uid, method)) adid =
let currentad = head (filter (\ad -> authOverviewId ad == adid) ads) let currentad = head (filter (\ad -> authOverviewId ad == adid) ads)
case authOverviewMethod currentad of case authOverviewMethod currentad of
PrimaryPass -> if validateDeletion ads PrimaryPass -> if validateDeletion ads
then void (deleteAuthDataById adid conn) then do
void (deleteAuthDataById adid conn)
return NoContent
else throwUnacceptableDeletionError else throwUnacceptableDeletionError
ChallengeResponse -> if validateDeletion ads ChallengeResponse -> if validateDeletion ads
then void (deleteAuthDataById adid conn) then do
void (deleteAuthDataById adid conn)
return NoContent
else throwUnacceptableDeletionError else throwUnacceptableDeletionError
_ -> void $ deleteAuthDataById adid conn _ -> do
void $ deleteAuthDataById adid conn
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "Unauthorized access" { errBody = "Unauthorized access"

View file

@ -64,10 +64,11 @@ avatarUpdate
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> Int -> Int
-> AvatarData -> AvatarData
-> MateHandler () -> MateHandler NoContent
avatarUpdate (Just _) aid ad = do avatarUpdate (Just _) aid ad = do
conn <- asks rsConnection conn <- asks rsConnection
void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn void $ updateAvatar aid ad (md5 $ BS.pack $ avatarDataData ad) conn
return NoContent
avatarUpdate Nothing _ _ = avatarUpdate Nothing _ _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."

View file

@ -35,13 +35,14 @@ journalShow Nothing _ _ =
journalCheck journalCheck
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> JournalCashCheck -> JournalCashCheck
-> MateHandler () -> MateHandler NoContent
journalCheck (Just (uid, method)) check = do journalCheck (Just (uid, method)) check = do
mayCheckJournal <- checkCapability uid roleCanManageJournal mayCheckJournal <- checkCapability uid roleCanManageJournal
if method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal if method `elem` [PrimaryPass, ChallengeResponse] && mayCheckJournal
then do then do
conn <- asks rsConnection conn <- asks rsConnection
void $ insertNewCashCheck check conn void $ insertNewCashCheck check conn
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "Wrong Authentication present" { errBody = "Wrong Authentication present"

View file

@ -48,7 +48,7 @@ productOverview pid = do
productStockRefill productStockRefill
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> [AmountRefill] -> [AmountRefill]
-> MateHandler () -> MateHandler NoContent
productStockRefill (Just (uid, auth)) amorefs = do productStockRefill (Just (uid, auth)) amorefs = do
mayRefill <- anyM mayRefill <- anyM
(checkCapability uid) (checkCapability uid)
@ -71,6 +71,7 @@ productStockRefill (Just (uid, auth)) amorefs = do
amorefs amorefs
then do then do
void $ manualProductAmountRefill amorefs conn void $ manualProductAmountRefill amorefs conn
return NoContent
else else
throwError $ err400 throwError $ err400
{ errBody = "Amounts less than 0 are not acceptable." { errBody = "Amounts less than 0 are not acceptable."
@ -91,7 +92,7 @@ productStockRefill Nothing _ =
productStockUpdate productStockUpdate
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> [AmountUpdate] -> [AmountUpdate]
-> MateHandler () -> MateHandler NoContent
productStockUpdate (Just (uid, method)) amoups = do productStockUpdate (Just (uid, method)) amoups = do
mayUpdateStock <- checkCapability uid roleCanManageProducts mayUpdateStock <- checkCapability uid roleCanManageProducts
if method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock if method `elem` [PrimaryPass, ChallengeResponse] && mayUpdateStock
@ -100,6 +101,7 @@ productStockUpdate (Just (uid, method)) amoups = do
then do then do
conn <- asks rsConnection conn <- asks rsConnection
void $ manualProductAmountUpdate amoups conn void $ manualProductAmountUpdate amoups conn
return NoContent
else else
throwError $ err400 throwError $ err400
{ errBody = "Amounts less than 0 are not acceptable." { errBody = "Amounts less than 0 are not acceptable."

View file

@ -41,12 +41,13 @@ roleUpdate
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> Int -> Int
-> RoleSubmit -> RoleSubmit
-> MateHandler () -> MateHandler NoContent
roleUpdate (Just (uid, auth)) id_ roleSubmit = do roleUpdate (Just (uid, auth)) id_ roleSubmit = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then do
void $ updateRole id_ roleSubmit =<< asks rsConnection void $ updateRole id_ roleSubmit =<< asks rsConnection
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "You are not authorized for this action." { errBody = "You are not authorized for this action."
@ -59,12 +60,13 @@ roleUpdate Nothing _ _ =
roleDelete roleDelete
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> Int -> Int
-> MateHandler () -> MateHandler NoContent
roleDelete (Just (uid, auth)) id_ = do roleDelete (Just (uid, auth)) id_ = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then do
void $ deleteRole id_ =<< asks rsConnection void $ deleteRole id_ =<< asks rsConnection
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "You are not authorized for this action." { errBody = "You are not authorized for this action."
@ -82,12 +84,13 @@ roleAssociationList =
roleAssociationSubmit roleAssociationSubmit
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> RoleAssociationSubmit -> RoleAssociationSubmit
-> MateHandler () -> MateHandler NoContent
roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do roleAssociationSubmit (Just (uid, auth)) (RoleAssociationSubmit auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then do
associateUserToRole auid arid =<< asks rsConnection associateUserToRole auid arid =<< asks rsConnection
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "You are not authorized for this action." { errBody = "You are not authorized for this action."
@ -100,12 +103,13 @@ roleAssociationSubmit Nothing _ =
roleAssociationDelete roleAssociationDelete
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> RoleAssociation -> RoleAssociation
-> MateHandler () -> MateHandler NoContent
roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do roleAssociationDelete (Just (uid, auth)) (RoleAssociation auid arid) = do
isRoleManager <- checkCapability uid roleCanManageRoles isRoleManager <- checkCapability uid roleCanManageRoles
if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager if auth `elem` [PrimaryPass, ChallengeResponse] && isRoleManager
then then do
void $ deleteAssociation auid arid =<< asks rsConnection void $ deleteAssociation auid arid =<< asks rsConnection
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "You are not authorized for this action." { errBody = "You are not authorized for this action."

View file

@ -78,7 +78,7 @@ userGetAll (Just (_, _)) = do
userUpdate userUpdate
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> UserDetailsSubmit -> UserDetailsSubmit
-> MateHandler () -> MateHandler NoContent
userUpdate Nothing _ = userUpdate Nothing _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -89,6 +89,7 @@ userUpdate (Just (aid, method)) uds =
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
conn <- asks rsConnection conn <- asks rsConnection
void $ updateUserDetails aid uds (utctDay now) conn void $ updateUserDetails aid uds (utctDay now) conn
return NoContent
else else
throwError $ err401 throwError $ err401
{ errBody = "Wrong Authentication present." { errBody = "Wrong Authentication present."
@ -96,11 +97,12 @@ userUpdate (Just (aid, method)) uds =
userUpdateTimestamp userUpdateTimestamp
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> MateHandler () -> MateHandler NoContent
userUpdateTimestamp (Just (aid, _)) = do userUpdateTimestamp (Just (aid, _)) = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
conn <- asks rsConnection conn <- asks rsConnection
void $ updateUserTimestamp aid (utctDay now) conn void $ updateUserTimestamp aid (utctDay now) conn
return NoContent
userUpdateTimestamp Nothing = userUpdateTimestamp Nothing =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -116,7 +118,7 @@ userList ref = do
userRecharge userRecharge
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> UserRecharge -> UserRecharge
-> MateHandler () -> MateHandler NoContent
userRecharge (Just (auid, _)) (UserRecharge amount) = do userRecharge (Just (auid, _)) (UserRecharge amount) = do
when (amount < 0) $ when (amount < 0) $
throwError $ err400 throwError $ err400
@ -132,6 +134,7 @@ userRecharge (Just (auid, _)) (UserRecharge amount) = do
) )
conn conn
void $ addToUserBalance auid amount conn void $ addToUserBalance auid amount conn
return NoContent
userRecharge Nothing _ = userRecharge Nothing _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -140,7 +143,7 @@ userRecharge Nothing _ =
userTransfer userTransfer
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> UserTransfer -> UserTransfer
-> MateHandler () -> MateHandler NoContent
userTransfer (Just (auid, method)) (UserTransfer target amount) = do userTransfer (Just (auid, method)) (UserTransfer target amount) = do
when (amount < 0) $ when (amount < 0) $
throwError $ err400 throwError $ err400
@ -167,6 +170,7 @@ userTransfer (Just (auid, method)) (UserTransfer target amount) = do
} }
void $ addToUserBalance auid (-amount) conn void $ addToUserBalance auid (-amount) conn
void $ addToUserBalance target amount conn void $ addToUserBalance target amount conn
return NoContent
userTransfer Nothing _ = userTransfer Nothing _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."
@ -176,7 +180,7 @@ userNotify
:: Maybe (Int, AuthMethod) :: Maybe (Int, AuthMethod)
-> [PurchaseDetail] -> [PurchaseDetail]
-> PurchaseResult -> PurchaseResult
-> MateHandler () -> MateHandler NoContent
userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
conn <- asks rsConnection conn <- asks rsConnection
authOV <- selectAuthOverviewById auid conn authOV <- selectAuthOverviewById auid conn
@ -240,8 +244,9 @@ userNotify (Just (auid, _)) boughtItems (PurchaseResult flag _) = do
userDetails userDetails
(__ "Purchase notification") (__ "Purchase notification")
messageText messageText
return NoContent
Nothing -> Nothing ->
return () return NoContent
userNotify Nothing _ _ = userNotify Nothing _ _ =
throwError $ err401 throwError $ err401
{ errBody = "No Authentication present." { errBody = "No Authentication present."

View file

@ -4,8 +4,10 @@ module Types.Amount where
import GHC.Generics import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.OpenApi
import Data.Time (UTCTime) import Data.Time (UTCTime)
-- internal imports -- internal imports
@ -22,7 +24,7 @@ instance ToJSON AmountUpdate where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AmountUpdate instance FromJSON AmountUpdate
instance ToSchema AmountUpdate
data AmountRefill = AmountRefill data AmountRefill = AmountRefill
{ amountRefillProductId :: Int { amountRefillProductId :: Int
@ -35,7 +37,7 @@ instance ToJSON AmountRefill where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AmountRefill instance FromJSON AmountRefill
instance ToSchema AmountRefill
data Amount = Amount data Amount = Amount
{ amountProductId :: Int { amountProductId :: Int

View file

@ -13,6 +13,8 @@ import Data.Time.Clock (UTCTime)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.OpenApi
import qualified Data.Text as T import qualified Data.Text as T
import Data.Text.Encoding import Data.Text.Encoding
@ -32,7 +34,7 @@ instance ToJSON TicketRequest where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON TicketRequest instance FromJSON TicketRequest
instance ToSchema TicketRequest
data AuthInfo = AuthInfo data AuthInfo = AuthInfo
{ authChallenge :: Maybe T.Text { authChallenge :: Maybe T.Text
@ -44,6 +46,7 @@ instance ToJSON AuthInfo where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthInfo instance FromJSON AuthInfo
instance ToSchema AuthInfo
-- instance ToDatabase AuthInfo where -- instance ToDatabase AuthInfo where
-- --
@ -71,6 +74,8 @@ instance ToJSON AuthMethod where
instance FromJSON AuthMethod instance FromJSON AuthMethod
instance ToSchema AuthMethod
instance ToParamSchema AuthMethod
data AuthSubmit = AuthSubmit data AuthSubmit = AuthSubmit
{ authSubmitMethod :: AuthMethod { authSubmitMethod :: AuthMethod
@ -83,7 +88,7 @@ instance ToJSON AuthSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthSubmit instance FromJSON AuthSubmit
instance ToSchema AuthSubmit
newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord) newtype AuthTicket = AuthTicket T.Text deriving (Show, Generic, Eq, Ord)
@ -91,7 +96,7 @@ instance ToJSON AuthTicket where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthTicket instance FromJSON AuthTicket
instance ToSchema AuthTicket
newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic) newtype AuthResponse = AuthResponse T.Text deriving (Show, Generic)
@ -99,7 +104,7 @@ instance ToJSON AuthResponse where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthResponse instance FromJSON AuthResponse
instance ToSchema AuthResponse
data AuthRequest = AuthRequest data AuthRequest = AuthRequest
{ authRequestTicket :: AuthTicket { authRequestTicket :: AuthTicket
@ -111,7 +116,7 @@ instance ToJSON AuthRequest where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthRequest instance FromJSON AuthRequest
instance ToSchema AuthRequest
data AuthResult data AuthResult
= Granted = Granted
@ -124,7 +129,7 @@ instance ToJSON AuthResult where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthResult instance FromJSON AuthResult
instance ToSchema AuthResult
newtype AuthToken = AuthToken T.Text deriving (Show, Generic) newtype AuthToken = AuthToken T.Text deriving (Show, Generic)
@ -132,7 +137,7 @@ instance ToJSON AuthToken where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthToken instance FromJSON AuthToken
instance ToSchema AuthToken
data Token = Token data Token = Token
{ tokenString :: T.Text { tokenString :: T.Text
@ -209,6 +214,7 @@ instance ToJSON AuthOverview where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AuthOverview instance FromJSON AuthOverview
instance ToSchema AuthOverview
-- instance ToDatabase AuthOverview where -- instance ToDatabase AuthOverview where
-- --

View file

@ -10,6 +10,7 @@ import Data.Text.Encoding (decodeUtf8)
import Data.Word (Word8) import Data.Word (Word8)
import Data.Aeson import Data.Aeson
import Data.OpenApi (ToSchema)
import GHC.Generics import GHC.Generics
@ -28,6 +29,7 @@ instance ToJSON Avatar where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON Avatar instance FromJSON Avatar
instance ToSchema Avatar
instance FromDatabase Avatar where instance FromDatabase Avatar where
type OutTuple Avatar = (Int, T.Text, ByteString, ByteString) type OutTuple Avatar = (Int, T.Text, ByteString, ByteString)
@ -46,6 +48,7 @@ instance ToJSON AvatarData where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON AvatarData instance FromJSON AvatarData
instance ToSchema AvatarData
instance FromDatabase AvatarData where instance FromDatabase AvatarData where
type OutTuple AvatarData = (T.Text, ByteString) type OutTuple AvatarData = (T.Text, ByteString)

View file

@ -7,6 +7,7 @@ import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Data.OpenApi (ToSchema)
data JournalEntry = JournalEntry data JournalEntry = JournalEntry
{ journalEntryId :: Int { journalEntryId :: Int
@ -23,7 +24,7 @@ instance ToJSON JournalEntry where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON JournalEntry instance FromJSON JournalEntry
instance ToSchema JournalEntry
data JournalSubmit = JournalSubmit data JournalSubmit = JournalSubmit
{ journalSubmitUser :: Maybe Int { journalSubmitUser :: Maybe Int
@ -36,7 +37,7 @@ instance ToJSON JournalSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON JournalSubmit instance FromJSON JournalSubmit
instance ToSchema JournalSubmit
data JournalCashCheck = JournalCashCheck data JournalCashCheck = JournalCashCheck
{ journalCashCheckUser :: Int { journalCashCheckUser :: Int
@ -48,6 +49,7 @@ instance ToJSON JournalCashCheck where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON JournalCashCheck instance FromJSON JournalCashCheck
instance ToSchema JournalCashCheck
data JournalAction data JournalAction
= CashCheck = CashCheck
@ -61,3 +63,4 @@ instance ToJSON JournalAction where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON JournalAction instance FromJSON JournalAction
instance ToSchema JournalAction

View file

@ -6,6 +6,7 @@ import qualified Data.Text as T
import Data.Aeson import Data.Aeson
import GHC.Generics import GHC.Generics
import Data.OpenApi (ToSchema)
data MetaInformation = MetaInformation data MetaInformation = MetaInformation
{ metaInfoVersion :: T.Text { metaInfoVersion :: T.Text
@ -18,3 +19,4 @@ instance ToJSON MetaInformation where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON MetaInformation instance FromJSON MetaInformation
instance ToSchema MetaInformation

View file

@ -5,6 +5,7 @@ module Types.Product where
import GHC.Generics import GHC.Generics
import Data.Aeson import Data.Aeson
import Data.OpenApi (ToSchema)
import qualified Data.Text as T import qualified Data.Text as T
@ -33,6 +34,7 @@ instance ToJSON Product where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON Product instance FromJSON Product
instance ToSchema Product
instance ToDatabase Product where instance ToDatabase Product where
@ -72,7 +74,7 @@ instance ToJSON ProductOverview where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON ProductOverview instance FromJSON ProductOverview
instance ToSchema ProductOverview
data ProductShortOverview = ProductShortOverview data ProductShortOverview = ProductShortOverview
{ productShortOverviewId :: Int { productShortOverviewId :: Int
@ -94,7 +96,7 @@ instance ToJSON ProductShortOverview where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON ProductShortOverview instance FromJSON ProductShortOverview
instance ToSchema ProductShortOverview
data ProductSubmit = ProductSubmit data ProductSubmit = ProductSubmit
{ productSubmitIdent :: T.Text { productSubmitIdent :: T.Text
@ -116,3 +118,4 @@ instance ToJSON ProductSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON ProductSubmit instance FromJSON ProductSubmit
instance ToSchema ProductSubmit

View file

@ -5,6 +5,7 @@ module Types.Purchase where
import Data.Aeson import Data.Aeson
import GHC.Generics import GHC.Generics
import Data.OpenApi (ToSchema)
data PurchaseDetail = PurchaseDetail data PurchaseDetail = PurchaseDetail
@ -17,7 +18,7 @@ instance ToJSON PurchaseDetail where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON PurchaseDetail instance FromJSON PurchaseDetail
instance ToSchema PurchaseDetail
data PurchaseResult = PurchaseResult data PurchaseResult = PurchaseResult
{ purchaseResultFlag :: PurchaseResultFlag { purchaseResultFlag :: PurchaseResultFlag
@ -29,7 +30,7 @@ instance ToJSON PurchaseResult where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON PurchaseResult instance FromJSON PurchaseResult
instance ToSchema PurchaseResult
data PurchaseResultFlag data PurchaseResultFlag
= PurchaseOK = PurchaseOK
@ -41,3 +42,4 @@ instance ToJSON PurchaseResultFlag where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON PurchaseResultFlag instance FromJSON PurchaseResultFlag
instance ToSchema PurchaseResultFlag

View file

@ -4,7 +4,7 @@ module Types.Role where
import qualified Data.Text as T import qualified Data.Text as T
import Data.Aeson import Data.Aeson
import Data.OpenApi (ToSchema)
import GHC.Generics import GHC.Generics
-- internal imports -- internal imports
@ -35,6 +35,7 @@ instance ToJSON Role where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON Role instance FromJSON Role
instance ToSchema Role
instance ToDatabase Role where instance ToDatabase Role where
@ -71,6 +72,7 @@ instance ToJSON RoleSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleSubmit instance FromJSON RoleSubmit
instance ToSchema RoleSubmit
data RoleAssociation = RoleAssociation data RoleAssociation = RoleAssociation
{ roleAssociationUser :: Int { roleAssociationUser :: Int
@ -82,6 +84,7 @@ instance ToJSON RoleAssociation where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleAssociation instance FromJSON RoleAssociation
instance ToSchema RoleAssociation
data RoleAssociationSubmit = RoleAssociationSubmit data RoleAssociationSubmit = RoleAssociationSubmit
{ roleAssociationSubmitUser :: Int { roleAssociationSubmitUser :: Int
@ -93,3 +96,4 @@ instance ToJSON RoleAssociationSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON RoleAssociationSubmit instance FromJSON RoleAssociationSubmit
instance ToSchema RoleAssociationSubmit

View file

@ -5,8 +5,8 @@ module Types.User where
import GHC.Generics import GHC.Generics
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Aeson import Data.Aeson
import Data.OpenApi (ToSchema)
import qualified Data.Text as T import qualified Data.Text as T
@ -54,7 +54,7 @@ instance ToJSON UserSummary where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserSummary instance FromJSON UserSummary
instance ToSchema UserSummary
data UserSubmit = UserSubmit data UserSubmit = UserSubmit
{ userSubmitIdent :: T.Text { userSubmitIdent :: T.Text
@ -67,7 +67,7 @@ instance ToJSON UserSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserSubmit instance FromJSON UserSubmit
instance ToSchema UserSubmit
data UserDetails = UserDetails data UserDetails = UserDetails
{ userDetailsId :: Int { userDetailsId :: Int
@ -84,7 +84,7 @@ instance ToJSON UserDetails where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserDetails instance FromJSON UserDetails
instance ToSchema UserDetails
data UserDetailsSubmit = UserDetailsSubmit data UserDetailsSubmit = UserDetailsSubmit
{ userDetailsSubmitIdent :: T.Text { userDetailsSubmitIdent :: T.Text
@ -99,7 +99,7 @@ instance ToJSON UserDetailsSubmit where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserDetailsSubmit instance FromJSON UserDetailsSubmit
instance ToSchema UserDetailsSubmit
newtype UserRecharge = UserRecharge newtype UserRecharge = UserRecharge
{ userRechargeAmount :: Int { userRechargeAmount :: Int
@ -110,7 +110,7 @@ instance ToJSON UserRecharge where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserRecharge instance FromJSON UserRecharge
instance ToSchema UserRecharge
data UserTransfer = UserTransfer data UserTransfer = UserTransfer
{ userTransferTarget :: Int { userTransferTarget :: Int
@ -122,3 +122,4 @@ instance ToJSON UserTransfer where
toEncoding = genericToEncoding defaultOptions toEncoding = genericToEncoding defaultOptions
instance FromJSON UserTransfer instance FromJSON UserTransfer
instance ToSchema UserTransfer

View file

@ -155,3 +155,11 @@ sendNotification mail = do
else else
print ("Warning: sending notification failed: Sendmail not present!" print ("Warning: sending notification failed: Sendmail not present!"
:: String) :: String)
err200 :: ServerError
err200 = ServerError
{ errHTTPCode = 200
, errBody = "OK"
, errReasonPhrase = "RequestScceeded"
, errHeaders = []
}