make ticketStore concrete

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

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;
       };

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 :<|>

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

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)
 

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

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

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