working things out

mateamt.cabal

@@ -35,7 +35,7 @@ executable mateamt
                      , opaleye
                      , aeson
                      , text
-                     , time ^>=1.9
+                     , time
                      , product-profunctors
                      , postgresql-simple
                      , warp

shell.nix

@@ -20,7 +20,6 @@ let
           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

@@ -25,6 +25,8 @@ import Control.Monad.IO.Class (liftIO)
 
 import Control.Monad (void)
 
+import Control.Monad.Reader
+
 import Control.Concurrent.STM.TVar
 
 -- internal imports
@@ -53,7 +55,7 @@ main = do
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)
 app initState = serveWithContext userApi genAuthServerContext $
-  hoistServer (runReaderT initState) users
+  hoistServer userApi (`runReaderT` initState) users
 
 userApi :: Proxy UserAPI
 userApi = Proxy
@@ -74,7 +76,7 @@ authHandler = mkAuthHandler handler
       return res
 
 users :: ServerT UserAPI (ReaderT ReadState Handler)
-users conn =
+users =
   ( userList :<|>
     userNew :<|>
     userUpdate
@@ -83,22 +85,27 @@ users conn =
     authSend
   )
   where
-    userList :: Maybe Refine -> Bool -> Handler [User]
+    userList :: Maybe Refine -> Bool -> MateHandler [User]
-    userList ref sw = liftIO $ userSelect conn ref sw
+    userList ref sw = liftIO $ do
+      conn <- rsConnection <$> ask
+      userSelect conn ref sw
 
-    userNew :: UserSubmit -> Handler Int
+    userNew :: UserSubmit -> MateHandler Int
     userNew  us = liftIO $ do
       now <- getCurrentTime
       randSalt <- random 8
+      conn <- rsConnection <$> ask
       head <$> runInsert_ conn (insertUser us (utctDay now) randSalt)
 
-    userUpdate :: (Int, UserSubmit) -> Handler ()
+    userUpdate :: (Int, UserSubmit) -> MateHandler ()
     userUpdate (id, us) = liftIO $ do
       now <- getCurrentTime
+      conn <- rsConnection <$> ask
       void $ runUpdate_ conn (updateUser id us (utctDay now))
 
-    authGet :: Int -> Handler AuthInfo
+    authGet :: Int -> MateHandler AuthInfo
-    authGet = liftIO . getUserAuthInfo conn
+    authGet id =
+      getUserAuthInfo id
 
-    authSend :: AuthRequest -> Handler AuthResult
+    authSend :: AuthRequest -> MateHandler AuthResult
     authSend _ = liftIO $ Granted <$> AuthToken <$> random 8

src/Model/Auth.hs

@@ -10,16 +10,18 @@ import Control.Monad.IO.Class (liftIO)
 
 import Control.Monad.Reader (ask)
 
+import Control.Concurrent.STM
+
 import Data.Profunctor.Product (p3)
 
 import qualified Database.PostgreSQL.Simple as PGS
 
 import Data.Text (Text)
 
-import Data.Fixed (Fixed(..))
+import qualified Data.Set as S
 
 import Data.Time.Calendar (Day)
-import Data.Time.Clock (secondsToNominalDiffTime)
+import Data.Time.Clock
 
 import Data.ByteString (ByteString)
 import Data.ByteString.Random
@@ -60,11 +62,12 @@ getUserAuthInfo
   :: PGS.Connection
   -> Int
   -> MateHandler AuthInfo
-getUserAuthInfo conn id = do
+getUserAuthInfo id = do
+  conn <- rsConnection <$> ask
   users <- liftIO $ runSelect conn (
     keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
       uid .== C.constant id) <<< queryTable userTable
-    ) :: IO
+    ) :: MateHandler
         [ ( Int
           , Text
           , Int
@@ -81,15 +84,48 @@ getUserAuthInfo conn id = do
       )
     users
 
+checkTicket
+  :: Ticket
+  -> AuthHash
+  -> MateHandler Token
+generateToken (Ticket _ id exp) hash = do
+  conn <- rsConnection <$> ask
+  users <- liftIO $ runSelect conn (
+    keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
+      uid .== C.cinstant id) <<< queryTable userTable
+    ) :: MateHandler
+        [ ( Int
+          , Text
+          , Int
+          , Day
+          , Maybe Text
+          , Maybe Int
+          , ByteString
+          , Maybe ByteString
+          , Maybe Int
+          )
+        ]
+  let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8)
+
 newTicket :: Int -> MateHandler AuthTicket
 newTicket id = do
   store <- rsTicketStore <$> ask
   rand <- liftIO $ random 23
-  later <- liftIO $ (addUTCTime (secondsToNominalDiffTime (MkFixed 23)) <$> getCurrentTime)
+  later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
-  let ticket = AuthTicket
+  let ticket = Ticket
-        { ticketId     = rand
+        { ticketId     = AuthTicket rand
         , ticketUser   = id
         , ticketExpiry = later
         }
-  liftIO $ modifyTVar store (\s -> insert tocket store)
+  liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
-  retur ticket
+  return (AuthTicket rand)
+
+processAuthRequest
+  :: AuthRequest
+  -> MateHandler AuthResult
+processAuthRequest (AuthRequest aticket hash) = do
+  store <- (liftIO . readTVarIO) <$> rsTicketStore <$> ask
+  let mticket = S.filter (\st -> ticketId st == aticket) store
+  case toList mticket of
+    [ticket] -> checkTicket ticket hash
+    _        -> return Denied