make ticketStore concrete

This commit is contained in:
nek0 2019-05-06 23:41:05 +02:00
parent 5e873d5a37
commit 89bc8294e2
8 changed files with 75 additions and 22 deletions

View file

@ -25,6 +25,7 @@ executable mateamt
, Types
, Types.Auth
, Types.Beverage
, Types.Reader
, Types.Refine
, Types.User
-- other-extensions:
@ -34,7 +35,7 @@ executable mateamt
, opaleye
, aeson
, text
, time
, time ^>=1.9
, product-profunctors
, postgresql-simple
, warp
@ -45,6 +46,7 @@ executable mateamt
, base16-bytestring
, random-bytestring
, containers
, StateVar
, stm
, mtl
hs-source-dirs: src
default-language: Haskell2010

View file

@ -5,9 +5,9 @@ let
inherit (nixpkgs) pkgs;
f = { mkDerivation, aeson, base, base16-bytestring, bytestring
, http-api-data, opaleye, postgresql-simple, product-profunctors
, random-bytestring, servant, servant-server, stdenv, text, time
, wai, wai-logger, warp
, containers, http-api-data, mtl, opaleye, postgresql-simple
, product-profunctors, random-bytestring, servant, servant-server
, stdenv, stm, text, time, wai, wai-logger, warp
}:
mkDerivation {
pname = "mateamt";
@ -16,10 +16,11 @@ let
isLibrary = false;
isExecutable = true;
executableHaskellDepends = [
aeson base base16-bytestring bytestring http-api-data opaleye
postgresql-simple product-profunctors random-bytestring servant
servant-server text time wai wai-logger warp
aeson base base16-bytestring bytestring containers http-api-data
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

@ -11,6 +11,8 @@ import Data.Time.Clock
import Data.ByteString.Random
import Data.Set (empty)
import Database.PostgreSQL.Simple
import Network.Wai
@ -23,6 +25,8 @@ import Control.Monad.IO.Class (liftIO)
import Control.Monad (void)
import Control.Concurrent.STM.TVar
-- internal imports
import API
@ -34,15 +38,22 @@ main :: IO ()
main = do
conn <- connectPostgreSQL
"host='localhost' port=5432 dbname='mateamt' user='mateamt' password='mateamt'"
store <- newTVarIO empty
execute_ conn initUser
execute_ conn initBeverage
execute_ conn initToken
withStdoutLogger $ \log -> do
let settings = setPort 3000 $ setLogger log defaultSettings
runSettings settings (app conn)
initState = ReadState
{ rsConnection = conn
, rsTicketStore = store
}
runSettings settings (app initState)
app :: Connection -> Application
app conn = serveWithContext userApi genAuthServerContext (users conn)
app :: ReadState -> Application
-- app conn = serveWithContext userApi genAuthServerContext (users conn)
app initState = serveWithContext userApi genAuthServerContext $
hoistServer (runReaderT initState) users
userApi :: Proxy UserAPI
userApi = Proxy
@ -62,7 +73,7 @@ authHandler = mkAuthHandler handler
_ -> False
return res
users :: Connection -> Server UserAPI
users :: ServerT UserAPI (ReaderT ReadState Handler)
users conn =
( userList :<|>
userNew :<|>

View file

@ -6,15 +6,23 @@ import GHC.Generics
import Control.Arrow ((<<<))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask)
import Data.Profunctor.Product (p3)
import qualified Database.PostgreSQL.Simple as PGS
import Data.Text (Text)
import Data.Fixed (Fixed(..))
import Data.Time.Calendar (Day)
import Data.Time.Clock (secondsToNominalDiffTime)
import Data.ByteString (ByteString)
import Data.ByteString.Random
import Data.Maybe (fromMaybe)
@ -24,6 +32,7 @@ import qualified Opaleye.Constant as C
-- internal imports
import Types.Auth
import Types.Reader
import Model.User
@ -50,9 +59,9 @@ tokenTable = table "token" (
getUserAuthInfo
:: PGS.Connection
-> Int
-> IO AuthInfo
-> MateHandler AuthInfo
getUserAuthInfo conn id = do
users <- runSelect conn (
users <- liftIO $ runSelect conn (
keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
uid .== C.constant id) <<< queryTable userTable
) :: IO
@ -67,7 +76,20 @@ getUserAuthInfo conn id = do
, Maybe Int
)
]
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> return $
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9)
head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) ->
AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket id
)
users
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
, ticketUser = id
, ticketExpiry = later
}
liftIO $ modifyTVar store (\s -> insert tocket store)
retur ticket

View file

@ -12,7 +12,7 @@ import Data.Profunctor.Product (p9)
import Data.Maybe (fromJust, isJust, fromMaybe)
import Data.ByteString hiding (head)
import Data.ByteString.Random
-- import Data.ByteString.Random
import Data.Int (Int64)

View file

@ -5,4 +5,5 @@ module Types
import Types.Auth as T
import Types.Beverage as T
import Types.Refine as T
import Types.Reader as T
import Types.User as T

View file

@ -16,12 +16,12 @@ import Data.Time.Clock (UTCTime)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.StateVar
import Data.IORef
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM.TVar (TVar)
-- internal imports
data AuthInfo = AuthInfo
@ -124,9 +124,7 @@ data Token = Token
instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = StateVar (S.Set Ticket)
{-# NOINLINE ticketStore #-}
type TicketStore = TVar (S.Set Ticket)
data Ticket = Ticket
{ ticketId :: AuthTicket

18
src/Types/Reader.hs Normal file
View file

@ -0,0 +1,18 @@
module Types.Reader where
import Servant (Handler)
import Control.Monad.Reader (ReaderT)
import Database.PostgreSQL.Simple (Connection)
-- internal imports
import Types.Auth (TicketStore)
data ReadState = ReadState
{ rsConnection :: Connection
, rsTicketStore :: TicketStore
}
type MateHandler = ReaderT ReadState Handler