stuff changed, especially in auth. Authentication works for now.

This commit is contained in:
nek0 2019-10-04 09:01:44 +02:00
parent dc15ce43d8
commit 22adf58f9b
6 changed files with 62 additions and 31 deletions

View file

@ -78,6 +78,7 @@ app initState =
productStockRefill :<|> productStockRefill :<|>
productStockUpdate :<|> productStockUpdate :<|>
productList :<|> productList :<|>
productShortList :<|>
buy :<|> buy :<|>

View file

@ -85,6 +85,7 @@ library
, http-api-data , http-api-data
, bytestring , bytestring
, base16-bytestring , base16-bytestring
, base64-bytestring
, random-bytestring , random-bytestring
, containers , containers
, stm , stm

View file

@ -52,6 +52,8 @@ type MateAPI =
:> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] () :> ReqBody '[JSON] [AmountUpdate] :> Put '[JSON] ()
:<|> "product" :> "list" :> QueryParam "refine" ProductRefine :<|> "product" :> "list" :> QueryParam "refine" ProductRefine
:> Get '[JSON] [ProductOverview] :> Get '[JSON] [ProductOverview]
:<|> "product" :> "shortlist" :> QueryParam "refine" ProductRefine
:> Get '[JSON] [ProductShortOverview]
:<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail] :<|> "buy" :> AuthProtect "header-auth" :> ReqBody '[JSON] [PurchaseDetail]
:> Post '[JSON] PurchaseResult :> Post '[JSON] PurchaseResult
@ -87,6 +89,7 @@ type MateAPI =
productStockRefillLink :<|> productStockRefillLink :<|>
productStockUpdateLink :<|> productStockUpdateLink :<|>
productListLink :<|> productListLink :<|>
productShortListLink :<|>
buyLink :<|> buyLink :<|>

View file

@ -75,3 +75,10 @@ productList
productList mrefine = do productList mrefine = do
conn <- rsConnection <$> ask conn <- rsConnection <$> ask
productOverviewSelect (fromMaybe AvailableProducts mrefine) conn productOverviewSelect (fromMaybe AvailableProducts mrefine) conn
productShortList
:: Maybe ProductRefine
-> MateHandler [ProductShortOverview]
productShortList mrefine = do
conn <- rsConnection <$> ask
productShortOverviewSelect (fromMaybe AvailableProducts mrefine) conn

View file

@ -2,6 +2,7 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Arrows #-} {-# LANGUAGE Arrows #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Model.Auth where module Model.Auth where
import Servant import Servant
@ -9,13 +10,10 @@ import Servant
import Control.Arrow import Control.Arrow
import Control.Monad (void) import Control.Monad (void)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask) import Control.Monad.Reader (ask)
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
import Control.Concurrent.STM import Control.Concurrent.STM
import Data.Profunctor.Product (p4, p5) import Data.Profunctor.Product (p4, p5)
@ -31,8 +29,10 @@ import qualified Data.Set as S
import Data.Time.Clock import Data.Time.Clock
import Data.ByteString (ByteString) import Data.ByteString as B (ByteString, drop)
import Data.ByteString.Random import Data.ByteString.Random
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base16 as B16
import Opaleye hiding (null) import Opaleye hiding (null)
import qualified Opaleye.Constant as C 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_user INTEGER NOT NULL REFERENCES \"user\"(\"user_id\") ON DELETE CASCADE,"
, "auth_data_method INTEGER NOT NULL," , "auth_data_method INTEGER NOT NULL,"
, "auth_data_comment TEXT 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 SqlInt4 , Field SqlInt4
, Field SqlText , Field SqlText
, Field SqlText , Field SqlBytea
) )
( Field SqlInt4 ( Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlInt4 , Field SqlInt4
, Field SqlText , Field SqlText
, Field SqlText , Field SqlBytea
) )
authDataTable = table "auth_data" ( authDataTable = table "auth_data" (
p5 p5
@ -114,7 +114,7 @@ delayTime = 1 * 10 ^ (6 :: Int)
generateRandomText :: IO T.Text generateRandomText :: IO T.Text
generateRandomText = decodeUtf8 <$> random 23 generateRandomText = decodeUtf8 <$> B64.encode <$> random 23
selectAuthOverviews selectAuthOverviews
@ -122,7 +122,7 @@ selectAuthOverviews
-> PGS.Connection -> PGS.Connection
-> MateHandler [AuthOverview] -> MateHandler [AuthOverview]
selectAuthOverviews uid conn = do selectAuthOverviews uid conn = do
authData <- liftIO $ runSelect conn ( proc () -> do authData <- liftIO $ runSelect conn (proc () -> do
(adid, aduid, admethod, adcomment, adpayload) <- (adid, aduid, admethod, adcomment, adpayload) <-
queryTable authDataTable -< () queryTable authDataTable -< ()
restrict -< aduid .== C.constant uid restrict -< aduid .== C.constant uid
@ -146,20 +146,24 @@ getUserAuthInfo
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthInfo -> MateHandler AuthInfo
getUserAuthInfo uid method conn = do getUserAuthInfo uid method conn = do
authdata <- liftIO $ do authdata <- map (\(aid, auid, amethod, acomment, apayload) ->
void $ threadDelay delayTime (aid, auid, amethod, acomment, (decodeUtf8 $ B64.encode apayload))) <$>
runSelect conn ( (liftIO $ do
keepWhen (\(_, duid, dmethod, _, _) -> void $ threadDelay delayTime
duid .== C.constant uid .&& dmethod .== C.constant (fromEnum method)) runSelect conn (proc () -> do
<<< queryTable authDataTable (aid, auid, amethod, acomment, apayload) <-
) :: IO queryTable authDataTable -< ()
[ ( Int restrict -<
, Int auid .== C.constant uid .&& amethod .== C.constant (fromEnum method)
, Int returnA -< (aid, auid, amethod, acomment, apayload)
, T.Text ) :: IO
, T.Text [ ( Int
) , Int
] , Int
, T.Text
, ByteString
)
])
if null authdata if null authdata
then then
-- generate mock AuthInfo -- generate mock AuthInfo
@ -189,7 +193,7 @@ putUserAuthInfo uid method comment payload conn =
, C.constant uid , C.constant uid
, C.constant (fromEnum method) , C.constant (fromEnum method)
, C.constant comment , C.constant comment
, C.constant payload , C.constant (encodeUtf8 payload)
) )
] ]
, iReturning = rReturning (\(adid, _, _, _, _) -> adid) , iReturning = rReturning (\(adid, _, _, _, _) -> adid)
@ -246,7 +250,7 @@ generateToken
-> AuthResponse -> AuthResponse
-> PGS.Connection -> PGS.Connection
-> MateHandler AuthResult -> MateHandler AuthResult
generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse rawresponse) conn = do
authData <- liftIO $ runSelect conn ( authData <- liftIO $ runSelect conn (
keepWhen (\(_, auid, amethod, _, _) -> keepWhen (\(_, auid, amethod, _, _) ->
auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method)) auid .== C.constant tuid .&& amethod .== C.constant (fromEnum method))
@ -256,14 +260,17 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
, Int , Int
, Int , Int
, T.Text , 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 authResult = case method of
PrimaryPass -> validatePass response userPayloads PrimaryPass -> validatePass response userPayloads
SecondaryPass -> validatePass response userPayloads SecondaryPass -> validatePass response userPayloads
ChallengeResponse -> validateChallengeResponse response userPayloads ChallengeResponse -> validateChallengeResponse response userPayloads
liftIO $ print (response : userPayloads)
if authResult if authResult
then do then do
token <- liftIO $ Token token <- liftIO $ Token
@ -279,7 +286,7 @@ generateToken (Ticket _ tuid _ (method, pl)) (AuthResponse response) conn = do
validatePass provided presents = validatePass provided presents =
any (\present -> provided == present) presents any (\present -> provided == present) presents
validateChallengeResponse provided presents = validateChallengeResponse provided presents =
error "Validation of challnge response authentication not yet implemented" error "Validation of challenge response authentication not yet implemented"
insertToken insertToken
@ -352,6 +359,7 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
let mticket = S.filter (\st -> ticketId st == aticket) store let mticket = S.filter (\st -> ticketId st == aticket) store
case S.toList mticket of case S.toList mticket of
[ticket] -> do [ticket] -> do
liftIO $ putStrLn "there is a ticket..."
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime
if now > ticketExpiry ticket if now > ticketExpiry ticket
@ -367,7 +375,8 @@ processAuthRequest (AuthRequest aticket hash) store conn = do
#else #else
return Denied return Denied
#endif #endif
else else do
liftIO $ putStrLn "...and it is valid"
generateToken ticket hash conn generateToken ticket hash conn
_ -> do _ -> do
liftIO $ threadDelay delayTime liftIO $ threadDelay delayTime

View file

@ -228,12 +228,22 @@ productOverviewSelectSingle pid conn = do
productShortOverviewSelect productShortOverviewSelect
:: PGS.Connection :: ProductRefine
-> PGS.Connection
-> MateHandler [ProductShortOverview] -> MateHandler [ProductShortOverview]
productShortOverviewSelect conn = do productShortOverviewSelect refine conn = do
prods <- liftIO $ runSelect conn prods <- liftIO $ runSelect conn
( proc () -> do ( proc () -> do
(i1, i2, i6, i7, i8, i9, i11, i12, i13) <- queryTable productTable -< () (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) returnA -< (i1, i2, i6, i7, i8, i9, i11, i12, i13)
) :: MateHandler ) :: MateHandler
[ ( Int [ ( Int