bla

src/Main.hs

@@ -54,12 +54,25 @@ main = do
 
 app :: ReadState -> Application
 -- app conn = serveWithContext userApi genAuthServerContext (users conn)
-app initState = serveWithContext userApi genAuthServerContext $
-  hoistServer userApi (`runReaderT` initState) users
+app initState = serve userApi $
+  hoistServerWithContext
+    userApi
+    authProxy
+    -- genAuthServerContext
+    (`runReaderT` initState)
+    users
+  -- hoistServerWithContext
+  --   userApi
+  --   genAuthServerContext
+  --   (`runReaderT` initState)
+  --   users
 
 userApi :: Proxy UserAPI
 userApi = Proxy
 
+authProxy :: Proxy (Context (AuthHandler Request Bool ': '[]))
+authProxy = Proxy
+
 genAuthServerContext :: Context (AuthHandler Request Bool ': '[])
 genAuthServerContext = authHandler Servant.:. EmptyContext
 
@@ -86,22 +99,22 @@ users =
   )
   where
     userList :: Maybe Refine -> Bool -> MateHandler [User]
-    userList ref sw = liftIO $ do
+    userList ref sw = do
       conn <- rsConnection <$> ask
       userSelect conn ref sw
 
     userNew :: UserSubmit -> MateHandler Int
-    userNew  us = liftIO $ do
-      now <- getCurrentTime
-      randSalt <- random 8
+    userNew  us = do
+      now <- liftIO $ getCurrentTime
+      randSalt <- liftIO $ random 8
       conn <- rsConnection <$> ask
-      head <$> runInsert_ conn (insertUser us (utctDay now) randSalt)
+      head <$> (liftIO $ runInsert_ conn (insertUser us (utctDay now) randSalt))
 
     userUpdate :: (Int, UserSubmit) -> MateHandler ()
-    userUpdate (id, us) = liftIO $ do
-      now <- getCurrentTime
+    userUpdate (id, us) = do
+      now <- liftIO $ getCurrentTime
       conn <- rsConnection <$> ask
-      void $ runUpdate_ conn (updateUser id us (utctDay now))
+      void $ liftIO $ runUpdate_ conn (updateUser id us (utctDay now))
 
     authGet :: Int -> MateHandler AuthInfo
     authGet id =

src/Model/Auth.hs

@@ -6,6 +6,8 @@ import GHC.Generics
 
 import Control.Arrow ((<<<))
 
+import Control.Monad (void)
+
 import Control.Monad.IO.Class (liftIO)
 
 import Control.Monad.Reader (ask)
@@ -59,14 +61,13 @@ tokenTable = table "token" (
     )
 
 getUserAuthInfo
-  :: PGS.Connection
-  -> Int
+  :: Int
   -> MateHandler AuthInfo
-getUserAuthInfo id = do
+getUserAuthInfo ident = do
   conn <- rsConnection <$> ask
   users <- liftIO $ runSelect conn (
     keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
-      uid .== C.constant id) <<< queryTable userTable
+      uid .== C.constant ident) <<< queryTable userTable
     ) :: MateHandler
         [ ( Int
           , Text
@@ -80,19 +81,19 @@ getUserAuthInfo id = do
           )
         ]
   head <$> mapM (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) ->
-      AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket id
+      AuthInfo (AuthSalt i7) (toEnum $ fromMaybe 0 i9) <$> newTicket ident
       )
     users
 
-checkTicket
+generateToken
   :: Ticket
   -> AuthHash
-  -> MateHandler Token
-generateToken (Ticket _ id exp) hash = do
+  -> MateHandler AuthResult
+generateToken (Ticket _ ident exp) (AuthHash hash) = do
   conn <- rsConnection <$> ask
   users <- liftIO $ runSelect conn (
     keepWhen (\(uid, _, _, _, _, _, _, _, _) ->
-      uid .== C.cinstant id) <<< queryTable userTable
+      uid .== C.constant ident) <<< queryTable userTable
     ) :: MateHandler
         [ ( Int
           , Text
@@ -105,16 +106,42 @@ generateToken (Ticket _ id exp) hash = do
           , Maybe Int
           )
         ]
-  let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8)
+  let userHash = head $ map (\(i1, i2, i3, i4, i5, i6, i7, i8, i9) -> i8) users
+  if userHash == Nothing || userHash == Just hash
+  then do
+    token <- liftIO $ Token
+      <$> (random 23)
+      <*> (pure ident)
+      <*> (addUTCTime 23 <$> getCurrentTime)
+    void $ liftIO $ runInsert_ conn (insertToken token)
+    return $ Granted (AuthToken $ tokenString token)
+  else
+    return Denied
+
+insertToken
+  :: Token
+  -> Insert [ByteString]
+insertToken (Token tString tUser tExpiry) = Insert
+  { iTable = tokenTable
+  , iRows =
+    [
+    ( C.constant tString
+    , C.constant tUser
+    , C.constant tExpiry
+    )
+    ]
+  , iReturning = rReturning (\(ident, _, _) -> ident)
+  , iOnConflict = Nothing
+  }
 
 newTicket :: Int -> MateHandler AuthTicket
-newTicket id = do
+newTicket ident = do
   store <- rsTicketStore <$> ask
   rand <- liftIO $ random 23
   later <- liftIO $ (addUTCTime (23/60) <$> getCurrentTime)
   let ticket = Ticket
         { ticketId     = AuthTicket rand
-        , ticketUser   = id
+        , ticketUser   = ident
         , ticketExpiry = later
         }
   liftIO $ atomically $ modifyTVar store (\s -> S.insert ticket s)
@@ -124,8 +151,8 @@ processAuthRequest
   :: AuthRequest
   -> MateHandler AuthResult
 processAuthRequest (AuthRequest aticket hash) = do
-  store <- (liftIO . readTVarIO) <$> rsTicketStore <$> ask
+  store <- liftIO . readTVarIO =<< rsTicketStore <$> ask
   let mticket = S.filter (\st -> ticketId st == aticket) store
-  case toList mticket of
-    [ticket] -> checkTicket ticket hash
+  case S.toList mticket of
+    [ticket] -> generateToken ticket hash
     _        -> return Denied

src/Model/User.hs

@@ -12,7 +12,6 @@ import Data.Profunctor.Product (p9)
 import Data.Maybe (fromJust, isJust, fromMaybe)
 
 import Data.ByteString hiding (head)
--- import Data.ByteString.Random
 
 import Data.Int (Int64)
 
@@ -22,6 +21,8 @@ import GHC.Generics
 
 import Control.Arrow ((<<<))
 
+import Control.Monad.IO.Class (liftIO)
+
 import Opaleye as O
 import qualified Opaleye.Constant as C
 
@@ -30,6 +31,7 @@ import qualified Opaleye.Constant as C
 import Types.User
 import Types.Refine
 import Types.Auth
+import Types.Reader
 
 initUser :: PGS.Query
 initUser = "create table if not exists \"user\" (user_id serial primary key, user_ident varchar(128) not null, user_balance integer not null, user_timestamp date not null, user_email varchar(128), user_avatar integer, user_salt bytea not null, user_hash bytea, user_algo integer)"
@@ -73,10 +75,10 @@ userSelect
   :: PGS.Connection
   -> Maybe Refine
   -> Bool
-  -> IO [User]
+  -> MateHandler [User]
 userSelect conn ref sw = do
-  today <- utctDay <$> getCurrentTime
-  users <- runSelect conn (case ref of
+  today <- utctDay <$> (liftIO $ getCurrentTime)
+  users <- liftIO $ runSelect conn (case ref of
       Nothing -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
         ts .>= C.constant (addDays (-30) today)
         ) <<< queryTable userTable
@@ -84,7 +86,7 @@ userSelect conn ref sw = do
       Just Old -> keepWhen (\(_, _, _, ts, _, _, _, _, _) ->
         ts .<= C.constant (addDays (-30) today)
         ) <<< queryTable userTable
-      ) :: IO
+      ) :: MateHandler
           [ ( Int
             , Text
             , Int
@@ -131,7 +133,7 @@ updateUser id us now = Update
       ( id_
       , C.constant (userSubmitIdent us)
       , i3
-      , C.constant (now)
+      , C.constant now
       , C.constant (userSubmitEmail us)
       , i6
       , i7

src/Types/Auth.hs

@@ -94,7 +94,7 @@ instance FromJSON AuthRequest
 
 data AuthResult
   = Granted
-    { authToken :: Token
+    { authToken :: AuthToken
     }
   | Denied
     deriving (Show, Generic)