diff --git a/mateamt.cabal b/mateamt.cabal index a990352..2689980 100644 --- a/mateamt.cabal +++ b/mateamt.cabal @@ -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 diff --git a/shell.nix b/shell.nix index a68df48..bc3aaac 100644 --- a/shell.nix +++ b/shell.nix @@ -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; }; diff --git a/src/Main.hs b/src/Main.hs index 81569ce..ba31c11 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 :<|> diff --git a/src/Model/Auth.hs b/src/Model/Auth.hs index cccfe53..ce3a9ff 100644 --- a/src/Model/Auth.hs +++ b/src/Model/Auth.hs @@ -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 diff --git a/src/Model/User.hs b/src/Model/User.hs index b513276..2e8b5e7 100644 --- a/src/Model/User.hs +++ b/src/Model/User.hs @@ -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) diff --git a/src/Types.hs b/src/Types.hs index ab6dbda..8d49e98 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Auth.hs b/src/Types/Auth.hs index 767314c..7b3d25c 100644 --- a/src/Types/Auth.hs +++ b/src/Types/Auth.hs @@ -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 diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs new file mode 100644 index 0000000..6cad660 --- /dev/null +++ b/src/Types/Reader.hs @@ -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