nek0/mateamt
1
0
Fork 0
Code Issues Pull requests Releases Activity

rebuild API properly to RESTfulness

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

46
src/API.hs
View file

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

260
src/Main.hs
View file

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

77
src/Model/Product.hs
View file

@ -105,7 +105,7 @@ productSelect
:: PGS.Connection
-> MateHandler [Product]
productSelect conn = do
bevs <- liftIO $ runSelect conn
prods <- liftIO $ runSelect conn
( keepWhen (\_ -> C.constant True) <<< queryTable productTable
) :: MateHandler
[ ( Int
@ -127,14 +127,14 @@ productSelect conn = do
(\(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
)
bevs
prods
productOverviewSelect
:: PGS.Connection
-> MateHandler [ProductOverview]
productOverviewSelect conn = do
bevs <- liftIO $ runSelect conn
prods <- liftIO $ runSelect conn
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
@ -190,14 +190,79 @@ productOverviewSelect conn = do
return $ ProductOverview
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
:: PGS.Connection
-> MateHandler [ProductShortOverview]
productShortOverviewSelect conn = do
bevs <- liftIO $ runSelect conn
prods <- liftIO $ runSelect conn
( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< ()
returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
@ -253,7 +318,7 @@ productShortOverviewSelect conn = do
return $ ProductShortOverview
i1 i2 i3 i4 i6 i7
)
bevs
prods
-- getProductPrice