rebuild API properly to RESTfulness

src/API.hs

@@ -22,29 +22,27 @@ import Model as M
 import Types
 
 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]
     :> 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] ()
-    )

src/Main.hs

@@ -65,10 +65,22 @@ app initState =
       userApi
       authProxy
       (`runReaderT` initState)
-      ( users :<|>
+      ( authGet :<|>
-        products :<|>
+        authSend :<|>
-        buy :<|>
+        authLogout :<|>
-        auth
+
+        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
+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
   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"
-        }

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