rebuild API properly to RESTfulness

This commit is contained in:
nek0 2019-08-06 20:15:54 +02:00
parent d1e48c8284
commit e3eb8e39c7
3 changed files with 224 additions and 159 deletions

View file

@ -22,29 +22,27 @@ import Model as M
import Types import Types
type UserAPI = type UserAPI =
"user" :> "auth" :> Capture "uid" Int :> Get '[JSON] AuthInfo
( "list" :> AuthProtect "header-auth" :<|> "auth" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
:> QueryParam "refine" Refine :> Get '[JSON] [User] :<|> "auth" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
:<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int :> Delete '[JSON] ()
:<|> "details" :> AuthProtect "header-auth"
:> Capture "id" Int :> Get '[JSON] UserDetails :<|> "user" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
:<|> "details" :> AuthProtect "header-auth" :<|> "user" :> AuthProtect "header-auth"
:> Capture "id" Int :> ReqBody '[JSON] UserDetailsSubmit :> Post '[JSON] () :> Capture "uid'" Int :> Get '[JSON] UserDetails
) :<|> "user" :> AuthProtect "header-auth"
:<|> "product" :> :> Capture "uid'" Int :> ReqBody '[JSON] UserDetailsSubmit :> Patch '[JSON] ()
( "list" :> Get '[JSON] [ProductOverview] :<|> "user" :> "list" :> AuthProtect "header-auth"
:<|> "new" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit :> QueryParam "refine" Refine :> Get '[JSON] [User]
:> Post '[JSON] Int
:<|> "update" :> AuthProtect "header-auth" :<|> "product" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
:> ReqBody '[JSON] [AmountUpdate] :> Post '[JSON] () :> Post '[JSON] Int
:<|> "refill" :> AuthProtect "header-auth" :<|> "product" :> Capture "pid" Int :> Get '[JSON] ProductOverview
:> ReqBody '[JSON] [AmountRefill] :> Post '[JSON] () :<|> "product" :> AuthProtect "header-auth"
) :> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] ()
:<|> "product" :> AuthProtect "header-auth"
:> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] ()
:<|> "product" :> "list" :> Get '[JSON] [ProductOverview]
:<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail] :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
:> Post '[JSON] PurchaseResult :> Post '[JSON] PurchaseResult
:<|> "auth" :>
( "get" :> ReqBody '[JSON] Int :> Post '[JSON] AuthInfo
:<|> "send" :> ReqBody '[JSON] AuthRequest :> Post '[JSON] AuthResult
:<|> "logout" :> AuthProtect "header-auth" :> ReqBody '[JSON] Int
:> Post '[JSON] ()
)

View file

@ -65,10 +65,22 @@ app initState =
userApi userApi
authProxy authProxy
(`runReaderT` initState) (`runReaderT` initState)
( users :<|> ( authGet :<|>
products :<|> authSend :<|>
buy :<|> authLogout :<|>
auth
userNew :<|>
userGet :<|>
userUpdate :<|>
userList :<|>
productNew :<|>
productOverview :<|>
productStockRefill :<|>
productStockUpdate :<|>
productList :<|>
buy
) )
userApi :: Proxy UserAPI userApi :: Proxy UserAPI
@ -97,110 +109,126 @@ authHandler conn = mkAuthHandler handler
return Nothing return Nothing
return res return res
users =
userList :<|>
userNew :<|>
userGetUpdate :<|>
userPostUpdate
where
userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
userList muid ref = do
conn <- rsConnection <$> ask
userSelect conn ref
userNew :: UserSubmit -> MateHandler Int authGet :: Int -> MateHandler AuthInfo
userNew us = do authGet id =
now <- liftIO $ getCurrentTime getUserAuthInfo id
randSalt <- liftIO $ random 8
conn <- rsConnection <$> ask
insertUser us (utctDay now) randSalt conn
userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails authSend :: AuthRequest -> MateHandler AuthResult
userGetUpdate Nothing _ = authSend = processAuthRequest
throwError $ err403
{ errBody = "No Authentication present"
}
userGetUpdate (Just aid) id =
if aid == id
then do
now <- liftIO $ getCurrentTime
conn <- rsConnection <$> ask
-- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
userDetailsSelect conn id
else
throwError $ err403
{ errBody = "Wrong Authentication present"
}
userPostUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler () authLogout :: Maybe Int -> Int -> MateHandler ()
use359c65b0e68b6607a03d39f908ca26827ab97fb6e21096rPostUpdate Nothing _ _ = authLogout (Just muid) luid = do
throwError $ err403 if muid == luid
{ errBody = "No Authentication present" then
} processLogout luid
userPostUpdate (Just aid) id uds = else
if aid == id throwError $ err403
then do { errBody = "Forbidden"
now <- liftIO $ getCurrentTime }
conn <- rsConnection <$> ask authLogout Nothing _ = do
void $ updateUserDetails id uds (utctDay now) conn throwError $ err403
else { errBody = "Forbidden"
throwError $ err403 }
{ errBody = "Wrong Authentication present"
}
userNew :: UserSubmit -> MateHandler Int
products = userNew us = do
listLong :<|> now <- liftIO $ getCurrentTime
new :<|> randSalt <- liftIO $ random 8
stockUpdate :<|> conn <- rsConnection <$> ask
stockRefill insertUser us (utctDay now) randSalt conn
where
listLong :: MateHandler [ProductOverview] userGet :: Maybe Int -> Int -> MateHandler UserDetails
listLong = do userGet Nothing _ =
conn <- rsConnection <$> ask throwError $ err403
productOverviewSelect conn { errBody = "No Authentication present"
}
new :: Maybe Int -> ProductSubmit -> MateHandler Int userGet (Just aid) id =
new (Just _) bevsub = do if aid == id
conn <- rsConnection <$> ask then do
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
bevid <- insertProduct bevsub conn conn <- rsConnection <$> ask
void $ insertNewEmptyAmount bevid now bevsub conn -- void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
return bevid userDetailsSelect conn id
new Nothing _ = else
throwError $ err403 throwError $ err403
{ errBody = "Wrong Authentication present"
stockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler () }
stockUpdate (Just _) amoups = do
if all ((>= 0) . amountUpdateRealAmount) amoups userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
then do userUpdate Nothing _ _ =
conn <- rsConnection <$> ask throwError $ err403
void $ manualProductAmountUpdate amoups conn { errBody = "No Authentication present"
else }
throwError $ err406 userUpdate (Just aid) id uds =
{ errBody = "Amounts less than 0 are not acceptable" if aid == id
} then do
stockUpdate Nothing _ = now <- liftIO $ getCurrentTime
throwError $ err403 conn <- rsConnection <$> ask
{ errBody = "No Authentication present" void $ updateUserDetails id uds (utctDay now) conn
} else
throwError $ err403
stockRefill :: Maybe Int -> [AmountRefill] -> MateHandler () { errBody = "Wrong Authentication present"
stockRefill (Just _) amorefs = do }
if all ((>= 0) . amountRefillAmount) amorefs
then do userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
conn <- rsConnection <$> ask userList muid ref = do
void $ manualProductAmountRefill amorefs conn conn <- rsConnection <$> ask
else userSelect conn ref
throwError $ err406
{ errBody = "Amounts less than 0 are not acceptable"
} productNew :: Maybe Int -> ProductSubmit -> MateHandler Int
stockRefill Nothing _ = productNew (Just _) bevsub = do
throwError $ err403 conn <- rsConnection <$> ask
{ errBody = "No Authentication present" now <- liftIO $ getCurrentTime
} bevid <- insertProduct bevsub conn
void $ insertNewEmptyAmount bevid now bevsub conn
return bevid
productNew Nothing _ =
throwError $ err403
productOverview :: Int -> MateHandler ProductOverview
productOverview pid = do
conn <- rsConnection <$> ask
productOverviewSelectSingle pid conn
productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
productStockRefill (Just _) amorefs = do
if all ((>= 0) . amountRefillAmount) amorefs
then do
conn <- rsConnection <$> ask
void $ manualProductAmountRefill amorefs conn
else
throwError $ err406
{ errBody = "Amounts less than 0 are not acceptable"
}
productStockRefill Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
productStockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
productStockUpdate (Just _) amoups = do
if all ((>= 0) . amountUpdateRealAmount) amoups
then do
conn <- rsConnection <$> ask
void $ manualProductAmountUpdate amoups conn
else
throwError $ err406
{ errBody = "Amounts less than 0 are not acceptable"
}
productStockUpdate Nothing _ =
throwError $ err403
{ errBody = "No Authentication present"
}
productList :: MateHandler [ProductOverview]
productList = do
conn <- rsConnection <$> ask
productOverviewSelect conn
buy :: Maybe Int -> [PurchaseDetail] -> MateHandler PurchaseResult
buy (Just auid) pds = do buy (Just auid) pds = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
(missing, real) <- foldM (\acc@(ms, rs) pd -> do (missing, real) <- foldM (\acc@(ms, rs) pd -> do
@ -260,29 +288,3 @@ buy Nothing pds = do
return $ PurchaseResult return $ PurchaseResult
(PayAmount price) (PayAmount price)
missing missing
auth =
authGet :<|>
authSend :<|>
authLogout
where
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id
authSend :: AuthRequest -> MateHandler AuthResult
authSend = processAuthRequest
authLogout :: Maybe Int -> Int -> MateHandler ()
authLogout (Just muid) luid = do
if muid == luid
then
processLogout luid
else
throwError $ err403
{ errBody = "Forbidden"
}
authLogout Nothing _ = do
throwError $ err403
{ errBody = "Forbidden"
}

View file

@ -105,7 +105,7 @@ productSelect
:: PGS.Connection :: PGS.Connection
-> MateHandler [Product] -> MateHandler [Product]
productSelect conn = do productSelect conn = do
bevs <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn
( keepWhen (\_ -> C.constant True) <<< queryTable productTable ( keepWhen (\_ -> C.constant True) <<< queryTable productTable
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int
@ -127,14 +127,14 @@ productSelect conn = do
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> return $ (\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> return $
Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 {-i10-} i11 i12 i13 Product i1 i2 {-i3 i4 i5-} i6 i7 i8 i9 {-i10-} i11 i12 i13
) )
bevs prods
productOverviewSelect productOverviewSelect
:: PGS.Connection :: PGS.Connection
-> MateHandler [ProductOverview] -> MateHandler [ProductOverview]
productOverviewSelect conn = do productOverviewSelect conn = do
bevs <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn
( proc () -> do ( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () (i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13) returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
@ -190,14 +190,79 @@ productOverviewSelect conn = do
return $ ProductOverview return $ ProductOverview
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13 i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
) )
bevs prods
productOverviewSelectSingle
:: Int
-> PGS.Connection
-> MateHandler ProductOverview
productOverviewSelectSingle pid conn = do
prods <- liftIO $ runSelect conn
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
restrict -< C.constant pid .== i1
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
) :: MateHandler
[ ( Int
, T.Text
-- , Int
-- , Int
-- , Int
, Int
, Maybe Int
, Maybe Int
, Int
-- , Int
, Int
, Maybe Int
, Maybe T.Text
)
]
head <$> mapM
(\(i1, i2, {-i3, i4, i5,-} i6, i7, i8, i9, {-i10,-} i11, i12, i13) -> do
amounts <- liftIO $ runSelect conn
( proc () -> do
stuff@(a1, _, _, _, _) <- orderBy (desc (\(_, ts, _, _, _) -> ts))
(queryTable amountTable) -< ()
restrict -< C.constant i1 .== a1
returnA -< stuff
) :: MateHandler
[ ( Int
, UTCTime
, Int
, Int
, Bool
)
]
(i3, i4) <- return $ (\(_, _, y, x, _) -> (x, y)) $ head amounts
i5 <- return $ (\(_, x) -> x) $
foldl
(\(bef, van) (_, _, amo, _, ver) ->
if ver
then (amo, if amo < bef then van + (bef - amo) else van)
else (amo, van)
)
(0, 0)
(Prelude.reverse amounts)
i10 <- return $ snd $ foldl (\(bef, tot) (_, _, amo, _, ver) ->
if ver
then (amo, tot)
else (amo, tot + max 0 (bef - amo))
)
(0, 0)
(Prelude.reverse amounts)
return $ ProductOverview
i1 i2 i3 i4 i5 i6 i7 i8 i9 i10 i11 i12 i13
)
prods
productShortOverviewSelect productShortOverviewSelect
:: PGS.Connection :: PGS.Connection
-> MateHandler [ProductShortOverview] -> MateHandler [ProductShortOverview]
productShortOverviewSelect conn = do productShortOverviewSelect conn = do
bevs <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn
( proc () -> do ( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () (i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13) returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
@ -253,7 +318,7 @@ productShortOverviewSelect conn = do
return $ ProductShortOverview return $ ProductShortOverview
i1 i2 i3 i4 i6 i7 i1 i2 i3 i4 i6 i7
) )
bevs prods
-- getProductPrice -- getProductPrice