working things out

This commit is contained in:
nek0 2019-05-09 01:24:58 +02:00
parent 221c41b7db
commit 770c20dde0
4 changed files with 62 additions and 20 deletions

View file

@ -35,7 +35,7 @@ executable mateamt
, opaleye
, aeson
, text
, time ^>=1.9
, time
, product-profunctors
, postgresql-simple
, warp

View file

@ -20,7 +20,6 @@ let
mtl opaleye postgresql-simple product-profunctors random-bytestring
servant servant-server stm text time wai wai-logger warp
];
jailbreak = true;
description = "A whole new matemat";
license = stdenv.lib.licenses.agpl3;
};

View file

@ -25,6 +25,8 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
import Control.Monad.Reader
import Control.Concurrent.STM.TVar
-- internal imports
@ -53,7 +55,7 @@ main = do
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $
hoistServer (runReaderT initState) users
hoistServer userApi (`runReaderT` initState) users
userApi :: Proxy UserAPI
userApi = Proxy
@ -74,7 +76,7 @@ authHandler = mkAuthHandler handler
return res
users :: ServerT UserAPI (ReaderT ReadState Handler)
users conn =
users =
( userList :<|>
userNew :<|>
userUpdate
@ -83,22 +85,27 @@ users conn =
authSend
)
where
userList :: Maybe Refine -> Bool -> Handler [User]
userList ref sw = liftIO $ userSelect conn ref sw
userList :: Maybe Refine -> Bool -> MateHandler [User]
userList ref sw = liftIO $ do
conn <- rsConnection <$> ask
userSelect conn ref sw
userNew :: UserSubmit -> Handler Int
userNew :: UserSubmit -> MateHandler Int
userNew us = liftIO $ do
now <- getCurrentTime
randSalt <- random 8
conn <- rsConnection <$> ask
head <$> runInsert_ conn (insertUser us (utctDay now) randSalt)
userUpdate :: (Int, UserSubmit) -> Handler ()
userUpdate :: (Int, UserSubmit) -> MateHandler ()
userUpdate (id, us) = liftIO $ do
now <- getCurrentTime
conn <- rsConnection <$> ask
void $ runUpdate_ conn (updateUser id us (utctDay now))
authGet :: Int -> Handler AuthInfo
authGet = liftIO . getUserAuthInfo conn
authGet :: Int -> MateHandler AuthInfo
authGet id =
getUserAuthInfo id
authSend :: AuthRequest -> Handler AuthResult
authSend :: AuthRequest -> MateHandler AuthResult
authSend _ = liftIO $ Granted <$> AuthToken <$> random 8

View file

@ -10,16 +10,18 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Control.Concurrent.STM
import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS
import Data.Text (Text)
import Data.Fixed (Fixed(..))
import qualified Data.Set as S
import Data.Time.Calendar (Day)
import Data.Time.Clock (secondsToNominalDiffTime)
import Data.Time.Clock
import Data.ByteString (ByteString)
import Data.ByteString.Random
@ -60,11 +62,12 @@ getUserAuthInfo
:: PGS.Connection
-> Int
-> MateHandler AuthInfo
getUserAuthInfo conn id = do
getUserAuthInfo id = do
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable
) :: IO
) :: MateHandler
[ ( Int
, Text
, Int
@ -81,15 +84,48 @@ getUserAuthInfo conn id = do
)
users
checkTicket
:: Ticket
-> AuthHash
-> MateHandler Token
generateToken (Ticket _ id exp) hash = do
conn <- rsConnection <$> ask
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.cinstant id) <<< queryTable userTable
) :: MateHandler
[ ( Int
, Text
, Int
, Day
, Maybe Text
, Maybe Int
, ByteString
, Maybe ByteString
, Maybe Int
)
]
let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8)
newTicket :: Int -> MateHandler AuthTicket
newTicket id = do
store <- rsTicketStore <$> ask
rand <- liftIO $ random 23
later <- liftIO $ (addUTCTime (secondsToNominalDiffTime (MkFixed 23)) <$> getCurrentTime)
let ticket = AuthTicket
{ ticketId = rand
later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
let ticket = Ticket
{ ticketId = AuthTicket rand
, ticketUser = id
, ticketExpiry = later
}
liftIO $ modifyTVar store (\s -> insert tocket store)
retur ticket
liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
return (AuthTicket rand)
processAuthRequest
:: AuthRequest
-> MateHandler AuthResult
processAuthRequest (AuthRequest aticket hash) = do
store <- (liftIO . readTVarIO) <$> rsTicketStore <$> ask
let mticket = S.filter (\st -> ticketId st == aticket) store
case toList mticket of
[ticket] -> checkTicket ticket hash
_ -> return Denied