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

View file

@ -5,9 +5,9 @@ let
inherit (nixpkgs) pkgs; inherit (nixpkgs) pkgs;
f = { mkDerivation, aeson, base, base16-bytestring, bytestring f = { mkDerivation, aeson, base, base16-bytestring, bytestring
, http-api-data, opaleye, postgresql-simple, product-profunctors , containers, http-api-data, mtl, opaleye, postgresql-simple
, random-bytestring, servant, servant-server, stdenv, text, time , product-profunctors, random-bytestring, servant, servant-server
, wai, wai-logger, warp , stdenv, stm, text, time, wai, wai-logger, warp
}: }:
mkDerivation { mkDerivation {
pname = "mateamt"; pname = "mateamt";
@ -16,10 +16,11 @@ let
isLibrary = false; isLibrary = false;
isExecutable = true; isExecutable = true;
executableHaskellDepends = [ executableHaskellDepends = [
aeson base base16-bytestring bytestring http-api-data opaleye aeson base base16-bytestring bytestring containers http-api-data
postgresql-simple product-profunctors random-bytestring servant mtl opaleye postgresql-simple product-profunctors random-bytestring
servant-server text time wai wai-logger warp servant servant-server stm text time wai wai-logger warp
]; ];
jailbreak = true;
description = "A whole new matemat"; description = "A whole new matemat";
license = stdenv.lib.licenses.agpl3; license = stdenv.lib.licenses.agpl3;
}; };

View file

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

View file

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

View file

@ -5,4 +5,5 @@ module Types
import Types.Auth as T import Types.Auth as T
import Types.Beverage as T import Types.Beverage as T
import Types.Refine as T import Types.Refine as T
import Types.Reader as T
import Types.User 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.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.StateVar
import Data.IORef import Data.IORef
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM.TVar (TVar)
-- internal imports -- internal imports
data AuthInfo = AuthInfo data AuthInfo = AuthInfo
@ -124,9 +124,7 @@ data Token = Token
instance ToJSON Token where instance ToJSON Token where
toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s toJSON (Token s _ _) = (String . decodeUtf8 . B16.encode) s
type TicketStore = StateVar (S.Set Ticket) type TicketStore = TVar (S.Set Ticket)
{-# NOINLINE ticketStore #-}
data Ticket = Ticket data Ticket = Ticket
{ ticketId :: AuthTicket { 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