diff --git a/src/API.hs b/src/API.hs index 8659908..4016b85 100644 --- a/src/API.hs +++ b/src/API.hs @@ -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] () - ) diff --git a/src/Main.hs b/src/Main.hs index 39b8ee4..bb0af17 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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" - } diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 32024a1..471f5f9 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -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