make ticketStore concrete
This commit is contained in:
parent
5e873d5a37
commit
89bc8294e2
8 changed files with 75 additions and 22 deletions
|
@ -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
|
||||||
|
|
13
shell.nix
13
shell.nix
|
@ -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;
|
||||||
};
|
};
|
||||||
|
|
19
src/Main.hs
19
src/Main.hs
|
@ -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 :<|>
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
18
src/Types/Reader.hs
Normal 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
|
Loading…
Reference in a new issue