auth process seems to work

src/Main.hs

@@ -54,11 +54,10 @@ main = do
 
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)
-app initState = serve userApi $
+app initState = serveWithContext userApi genAuthServerContext $
   hoistServerWithContext
     userApi
     authProxy
-    -- genAuthServerContext
     (`runReaderT` initState)
     users
   -- hoistServerWithContext
@@ -70,10 +69,10 @@ app initState = serve userApi $
 userApi :: Proxy UserAPI
 userApi = Proxy
 
-authProxy :: Proxy (Context (AuthHandler Request Bool ': '[]))
+authProxy :: Proxy '[ AuthHandler Request Bool ]
 authProxy = Proxy
 
-genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
+genAuthServerContext :: Context '[ AuthHandler Request Bool ]
 genAuthServerContext = authHandler Servant.:. EmptyContext
 
 type instance AuthServerData (AuthProtect "header-auth") = Bool
@@ -104,7 +103,7 @@ users =
       userSelect conn ref sw
 
     userNew :: UserSubmit -> MateHandler Int
-    userNew  us = do
+    userNew us = do
       now <- liftIO $ getCurrentTime
       randSalt <- liftIO $ random 8
       conn <- rsConnection <$> ask
@@ -121,4 +120,4 @@ users =
       getUserAuthInfo id
 
     authSend :: AuthRequest -> MateHandler AuthResult
-    authSend _ = liftIO $ Granted <$> AuthToken <$> random 8
+    authSend = processAuthRequest

src/Model/Auth.hs

@@ -112,7 +112,7 @@ generateToken (Ticket _ ident exp) (AuthHash hash) = do
     token <- liftIO $ Token
       <$> (random 23)
       <*> (pure ident)
-      <*> (addUTCTime 23 <$> getCurrentTime)
+      <*> (addUTCTime (23*60) <$> getCurrentTime)
     void $ liftIO $ runInsert_ conn (insertToken token)
     return $ Granted (AuthToken $ tokenString token)
   else
@@ -138,7 +138,7 @@ newTicket :: Int -> MateHandler AuthTicket
 newTicket ident = do
   store <- rsTicketStore <$> ask
   rand <- liftIO $ random 23
-  later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
+  later <- liftIO $ (addUTCTime 23 <$> getCurrentTime)
   let ticket = Ticket
         { ticketId     = AuthTicket rand
         , ticketUser   = ident
@@ -154,5 +154,11 @@ processAuthRequest (AuthRequest aticket hash) = do
   store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
   let mticket = S.filter (\st -> ticketId st == aticket) store
   case S.toList mticket of
-    [ticket] -> generateToken ticket hash
+    [ticket] -> do
+      now <- liftIO $ getCurrentTime
+      if now > ticketExpiry ticket
+      then
+        return Denied
+      else
+        generateToken ticket hash
     _        -> return Denied