diff --git a/app/Main.hs b/app/Main.hs index b1d0155..91fefdf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -78,6 +78,7 @@ app initState = productStockRefill :<|> productStockUpdate :<|> productList :<|> + productShortList :<|> buy :<|> diff --git a/mateamt.cabal b/mateamt.cabal index 5b6f7be..8fd4fa6 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -85,6 +85,7 @@ library , http-api-data , bytestring , base16-bytestring + , base64-bytestring , random-bytestring , containers , stm diff --git a/src/API.hs b/src/API.hs index 787f3d0..7ef3dc6 100644 --- a/src/API.hs +++ b/src/API.hs @@ -52,6 +52,8 @@ type MateAPI = :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] () :<|> "product" :> "list" :> QueryParam "refine" ProductRefine :> Get '[JSON] [ProductOverview] + :<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine + :> Get '[JSON] [ProductShortOverview] :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail] :> Post '[JSON] PurchaseResult @@ -87,6 +89,7 @@ type MateAPI = productStockRefillLink :<|> productStockUpdateLink :<|> productListLink :<|> + productShortListLink :<|> buyLink :<|> diff --git a/src/Control/Product.hs b/src/Control/Product.hs index 84f21eb..a2dcf0c 100644 --- a/src/Control/Product.hs +++ b/src/Control/Product.hs @@ -75,3 +75,10 @@ productList productList mrefine = do conn <- rsConnection <$> ask productOverviewSelect (fromMaybe AvailableProducts mrefine) conn + +productShortList + :: Maybe ProductRefine + -> MateHandler [ProductShortOverview] +productShortList mrefine = do + conn <- rsConnection <$> ask + productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index b839a21..a4981aa 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Arrows #-} +{-# LANGUAGE ScopedTypeVariables #-} module Model.Auth where import Servant @@ -9,13 +10,10 @@ import Servant import Control.Arrow import Control.Monad (void) - import Control.Monad.IO.Class (liftIO) - import Control.Monad.Reader (ask) import Control.Concurrent (threadDelay) - import Control.Concurrent.STM import Data.Profunctor.Product (p4, p5) @@ -31,8 +29,10 @@ import qualified Data.Set as S import Data.Time.Clock -import Data.ByteString (ByteString) +import Data.ByteString as B (ByteString, drop) import Data.ByteString.Random +import qualified Data.ByteString.Base64 as B64 +import qualified Data.ByteString.Base16 as B16 import Opaleye hiding (null) import qualified Opaleye.Constant as C @@ -81,7 +81,7 @@ initAuthData = mconcat , "auth_data_user INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE," , "auth_data_method INTEGER NOT NULL," , "auth_data_comment TEXT NOT NULL," - , "auth_data_payload TEXT NOT NULL" + , "auth_data_payload BYTEA NOT NULL" , ")" ] @@ -90,13 +90,13 @@ authDataTable :: Table , Field SqlInt4 , Field SqlInt4 , Field SqlText - , Field SqlText + , Field SqlBytea ) ( Field SqlInt4 , Field SqlInt4 , Field SqlInt4 , Field SqlText - , Field SqlText + , Field SqlBytea ) authDataTable = table "auth_data" ( p5 @@ -114,7 +114,7 @@ delayTime = 1 * 10 ^ (6 :: Int) generateRandomText :: IO T.Text -generateRandomText = decodeUtf8 <$> random 23 +generateRandomText = decodeUtf8 <$> B64.encode <$> random 23 selectAuthOverviews @@ -122,7 +122,7 @@ selectAuthOverviews -> PGS.Connection -> MateHandler [AuthOverview] selectAuthOverviews uid conn = do - authData <- liftIO $ runSelect conn ( proc () -> do + authData <- liftIO $ runSelect conn (proc () -> do (adid, aduid, admethod, adcomment, adpayload) <- queryTable authDataTable -< () restrict -< aduid .== C.constant uid @@ -146,20 +146,24 @@ getUserAuthInfo -> PGS.Connection -> MateHandler AuthInfo getUserAuthInfo uid method conn = do - authdata <- liftIO $ do - void $ threadDelay delayTime - runSelect conn ( - keepWhen (\(_, duid, dmethod, _, _) -> - duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method)) - <<< queryTable authDataTable - ) :: IO - [ ( Int - , Int - , Int - , T.Text - , T.Text - ) - ] + authdata <- map (\(aid, auid, amethod, acomment, apayload) -> + (aid, auid, amethod, acomment, (decodeUtf8 $ B64.encode apayload))) <$> + (liftIO $ do + void $ threadDelay delayTime + runSelect conn (proc () -> do + (aid, auid, amethod, acomment, apayload) <- + queryTable authDataTable -< () + restrict -< + auid .== C.constant uid .&& amethod .== C.constant (fromEnum method) + returnA -< (aid, auid, amethod, acomment, apayload) + ) :: IO + [ ( Int + , Int + , Int + , T.Text + , ByteString + ) + ]) if null authdata then -- generate mock AuthInfo @@ -189,7 +193,7 @@ putUserAuthInfo uid method comment payload conn = , C.constant uid , C.constant (fromEnum method) , C.constant comment - , C.constant payload + , C.constant (encodeUtf8 payload) ) ] , iReturning = rReturning (\(adid, _, _, _, _) -> adid) @@ -246,7 +250,7 @@ generateToken -> AuthResponse -> PGS.Connection -> MateHandler AuthResult -generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do +generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse rawresponse) conn = do authData <- liftIO $ runSelect conn ( keepWhen (\(_, auid, amethod, _, _) -> auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) @@ -256,14 +260,17 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do , Int , Int , T.Text - , T.Text + , ByteString ) ] - let userPayloads = map (\(_, _, _, _, payload) -> payload) authData + let userPayloads = map (\(_, _, _, _, payload) -> + (decodeUtf8 $ fst $ B16.decode $ B.drop 2 payload)) authData + response = rawresponse authResult = case method of PrimaryPass -> validatePass response userPayloads SecondaryPass -> validatePass response userPayloads ChallengeResponse -> validateChallengeResponse response userPayloads + liftIO $ print (response : userPayloads) if authResult then do token <- liftIO $ Token @@ -279,7 +286,7 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do validatePass provided presents = any (\present -> provided == present) presents validateChallengeResponse provided presents = - error "Validation of challnge response authentication not yet implemented" + error "Validation of challenge response authentication not yet implemented" insertToken @@ -352,6 +359,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do let mticket = S.filter (\st -> ticketId st == aticket) store case S.toList mticket of [ticket] -> do + liftIO $ putStrLn "there is a ticket..." now <- liftIO $ getCurrentTime liftIO $ threadDelay delayTime if now > ticketExpiry ticket @@ -367,7 +375,8 @@ processAuthRequest (AuthRequest aticket hash) store conn = do #else return Denied #endif - else + else do + liftIO $ putStrLn "...and it is valid" generateToken ticket hash conn _ -> do liftIO $ threadDelay delayTime diff --git a/src/Model/Product.hs b/src/Model/Product.hs index 8dc2ab5..06f6c7b 100644 --- a/src/Model/Product.hs +++ b/src/Model/Product.hs @@ -228,12 +228,22 @@ productOverviewSelectSingle pid conn = do productShortOverviewSelect - :: PGS.Connection + :: ProductRefine + -> PGS.Connection -> MateHandler [ProductShortOverview] -productShortOverviewSelect conn = do +productShortOverviewSelect refine conn = do prods <- liftIO $ runSelect conn ( proc () -> do (i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () + (a1, a2, a3, a4, a5) <- + limit 1 ( + orderBy (desc (\(_, ts, _, _, _) -> ts)) (queryTable amountTable)) + -< () + restrict -< a1 .== i1 + restrict -< case refine of + AllProducts -> C.constant True + AvailableProducts -> a3 ./= C.constant (0 :: Int) + DepletedProducts -> a3 .== C.constant (0 :: Int) returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13) ) :: MateHandler [ ( Int