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 :<|>
productStockUpdate :<|>
productList :<|>
productShortList :<|>
buy :<|>

View File

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

View File

@ -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 :<|>

View File

@ -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

View File

@ -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

View File

@ -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