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
+  :<|> "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]
-    :<|> "new" :> ReqBody '[JSON] UserSubmit :> Post '[JSON] Int
+
-    :<|> "details" :> AuthProtect "header-auth"
+  :<|> "product" :> AuthProtect "header-auth" :> ReqBody '[JSON] ProductSubmit
-      :> 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"
+  :<|> "product" :> Capture "pid" Int :> Get '[JSON] ProductOverview
-      :> ReqBody '[JSON] [AmountUpdate] :> Post '[JSON] ()
+  :<|> "product" :> AuthProtect "header-auth"
-    :<|> "refill" :> AuthProtect "header-auth"
+    :> ReqBody '[JSON] [AmountRefill] :> Patch '[JSON] ()
-      :> ReqBody '[JSON] [AmountRefill] :> Post '[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,30 +109,42 @@ 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 =
+  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"
+    }
+
+
+userNew :: UserSubmit -> MateHandler Int
+userNew us = do
   now <- liftIO $ getCurrentTime
   randSalt <- liftIO $ random 8
   conn <- rsConnection <$> ask
   insertUser us (utctDay now) randSalt conn
 
-    userGetUpdate :: Maybe Int -> Int -> MateHandler UserDetails
+userGet :: Maybe Int -> Int -> MateHandler UserDetails
-    userGetUpdate Nothing _ =
+userGet Nothing _ =
   throwError $ err403
     { errBody = "No Authentication present"
     }
-    userGetUpdate (Just aid) id =
+userGet (Just aid) id =
   if aid == id
   then do
     now <- liftIO $ getCurrentTime
@@ -132,12 +156,12 @@ users =
       { errBody = "Wrong Authentication present"
       }
 
-    userPostUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
+userUpdate :: Maybe Int -> Int -> UserDetailsSubmit -> MateHandler ()
-    use359c65b0e68b6607a03d39f908ca26827ab97fb6e21096rPostUpdate Nothing _ _ =
+userUpdate Nothing _ _ =
   throwError $ err403
     { errBody = "No Authentication present"
     }
-    userPostUpdate (Just aid) id uds =
+userUpdate (Just aid) id uds =
   if aid == id
   then do
     now <- liftIO $ getCurrentTime
@@ -148,44 +172,29 @@ users =
       { errBody = "Wrong Authentication present"
       }
 
-products =
+userList :: Maybe Int -> Maybe Refine -> MateHandler [User]
-  listLong :<|>
+userList muid ref = do
-  new :<|>
-  stockUpdate :<|>
-  stockRefill
-  where
-    listLong :: MateHandler [ProductOverview]
-    listLong = do
   conn <- rsConnection <$> ask
-      productOverviewSelect conn
+  userSelect conn ref
 
-    new :: Maybe Int -> ProductSubmit -> MateHandler Int
+
-    new (Just _) bevsub = do
+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
-    new Nothing _ =
+productNew Nothing _ =
   throwError $ err403
 
-    stockUpdate :: Maybe Int -> [AmountUpdate] -> MateHandler ()
+productOverview :: Int -> MateHandler ProductOverview
-    stockUpdate (Just _) amoups = do
+productOverview pid = do
-      if all ((>= 0) . amountUpdateRealAmount) amoups
-      then do
   conn <- rsConnection <$> ask
-        void $ manualProductAmountUpdate amoups conn
+  productOverviewSelectSingle pid 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 ()
+productStockRefill :: Maybe Int -> [AmountRefill] -> MateHandler ()
-    stockRefill (Just _) amorefs = do
+productStockRefill (Just _) amorefs = do
   if all ((>= 0) . amountRefillAmount) amorefs
   then do
     conn <- rsConnection <$> ask
@@ -194,13 +203,32 @@ products =
     throwError $ err406
       { errBody = "Amounts less than 0 are not acceptable"
       }
-    stockRefill Nothing _ =
+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