removed specific user types from library

README.md

@@ -1 +1,5 @@
 # oauth2-mock-server
+ Windows:
+ ```
+ ghcup run --mingw-path -- stack run
+ ```

app/Main.hs

@@ -7,14 +7,15 @@ import Server
 import Control.Applicative ((<|>))
 import System.Environment (lookupEnv)
 import qualified Data.Map as M
+import qualified Data.Text as T
 
 main :: IO ()
 main = do
   port <- determinePort
   putStrLn $ "Try: http://localhost:" ++ show port ++ "/auth?scope=ID%20Profile&client_id=42&response_type=code&redirect_uri=http:%2F%2Flocalhost:0000%2F"
-  runMockServer port testUsers
+  runMockServer @User @(M.Map T.Text T.Text) port
     where
       determinePort :: IO Int
       determinePort = do
-        Just port <- (read @Int <$> lookupEnv "OAUTH2_SERVER_PORT") <|> Just 9443
+        Just port <- lookupEnv "OAUTH2_SERVER_PORT" >>= \p -> return $ p <|> Just "9443"
-        return port
+        return $ read @Int port

app/UniWorX.hs

@@ -1,4 +1,17 @@
-{-# Language GADTs, GeneralizedNewtypeDeriving, OverloadedStrings, QuasiQuotes, TemplateHaskell, TypeFamilies #-}
+{-# Language GADTs,
+             GeneralizedNewtypeDeriving,
+             OverloadedStrings,
+             QuasiQuotes,
+             TemplateHaskell,
+             TypeFamilies,
+             TypeApplications,
+             DerivingStrategies,
+             StandaloneDeriving,
+             UndecidableInstances,
+             DataKinds,
+             FlexibleInstances,
+             MultiParamTypeClasses,
+             RecordWildCards #-}
 
 module UniWorX (User(..), initDB, testUsers) where
 
@@ -6,6 +19,17 @@ import User
 
 import Control.Applicative ((<|>))
 import Control.Monad (void, forM_)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Logger (runStderrLoggingT, NoLoggingT)
+import Control.Monad.Reader (ReaderT)
+
+import Conduit (ResourceT)
+
+import Data.Map (Map(..))
+import Data.String (IsString(..))
+import Data.Text (Text(..))
+import qualified Data.Map as M
+import qualified Data.Text as T
 
 import Database.Persist
 import Database.Persist.TH
@@ -23,15 +47,15 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 
 testUsers :: [User] -- TODO move to db
 testUsers =
-  [ User {name = "Fallback User", email = "foo@bar.com"}
+  [ User "Fallback User" "foo@bar.com"
-  , User {name = "Tina Tester", email = "t@t.tt"}
+  , User "Tina Tester" "t@t.tt"
-  , User {name = "Max Muster", email = "m@m.mm"}]
+  , User "Max Muster" "m@m.mm"]
 
-runDB :: IO a -> IO a
+runDB :: ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> IO a
 runDB action = do
-  Just port <- lookupEnv "OAUTH2_DB_PORT" <|> Just "9444"
+  Just port <- lookupEnv "OAUTH2_DB_PORT" >>= \p -> return $ p <|> Just "9444"
-  let connStr = "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port
+  let connStr = fromString @ConnectionString $ "host=localhost dbname=test_users user=oauth2mock password=0000 port=" ++ port
-  withPostgresqlPool connStr 10 $ \pool -> flip runSqlPersistMPool pool action
+  runStderrLoggingT $ withPostgresqlPool connStr 10 $ \pool -> liftIO $ flip runSqlPersistMPool pool action
 
 initDB :: IO ()
 initDB = runDB $ do
@@ -42,11 +66,11 @@ instance UserData User (Map Text Text) where
   data Scope User = ID | Profile deriving (Show, Read, Eq)
   readScope = read
   showScope = show
-  userScope (Entity uID _) ID = singleton "id" uID
+  userScope (Entity uID _) ID = M.singleton "id" . T.pack $ show uID
-  userScope (Entity _ User{..}) Profile = fromList [("name", name), ("email", email)]
+  userScope (Entity _ User{..}) Profile = M.fromList [("name", userName), ("email", userEmail)]
   lookupUser email _ = runDB $ do
-    user <- selectList [UserEmail ==. e] []
+    user <- selectList [UserEmail ==. email] []
     case user of
-      [Entity _ u] -> return $ Just u
+      [entity] -> return $ Just entity
-      [] -> Nothing
+      [] -> return Nothing
       _ -> error "Ambiguous User."

oauth2-mock-server.cabal

@@ -37,11 +37,14 @@ library
     , base64
     , blaze-html
     , bytestring
+    , conduit
     , containers
     , http-api-data
     , http-client
     , http-media
     , jose-jwt
+    , monad-logger
+    , mtl
     , persistent
     , persistent-postgresql
     , persistent-template
@@ -73,11 +76,14 @@ executable oauth2-mock-server-exe
     , base64
     , blaze-html
     , bytestring
+    , conduit
     , containers
     , http-api-data
     , http-client
     , http-media
     , jose-jwt
+    , monad-logger
+    , mtl
     , oauth2-mock-server
     , persistent
     , persistent-postgresql
@@ -110,11 +116,14 @@ test-suite oauth2-mock-server-test
     , base64
     , blaze-html
     , bytestring
+    , conduit
     , containers
     , http-api-data
     , http-client
     , http-media
     , jose-jwt
+    , monad-logger
+    , mtl
     , oauth2-mock-server
     , persistent
     , persistent-postgresql

package.yaml

@@ -43,6 +43,9 @@ dependencies:
 - persistent
 - persistent-postgresql
 - persistent-template
+- monad-logger
+- conduit
+- mtl
 
 ghc-options:
 - -Wall

src/AuthCode.hs

@@ -21,6 +21,8 @@ import Data.UUID
 
 import qualified Data.Map.Strict as M
 
+import Database.Persist (Entity(..))
+
 import Control.Concurrent (forkIO, threadDelay)
 import Control.Concurrent.STM.TVar
 import Control.Monad (void, (>=>))
@@ -45,7 +47,7 @@ instance FromJSON JWT where
 data AuthRequest user = AuthRequest
   { client :: String
   , codeExpiration :: NominalDiffTime
-  , user :: user
+  , user :: Entity user
   , scopes :: [Scope user]
   }
 
@@ -53,7 +55,7 @@ data AuthRequest user = AuthRequest
 
 data State user = State
   { activeCodes :: Map Text (AuthRequest user)
-  , activeTokens :: Map UUID (user, [Scope user])
+  , activeTokens :: Map UUID (Entity user, [Scope user])
   , publicKey   :: Jwk
   , privateKey  :: Jwk
   }
@@ -84,7 +86,7 @@ expire code time state = void . forkIO $ do
   atomically . modifyTVar state $ \s -> s{ activeCodes = M.delete code s.activeCodes }
 
 
-verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (user, [Scope user]))
+verify :: Text -> Maybe String -> AuthState user -> IO (Maybe (Entity user, [Scope user]))
 verify code mClientID state = do
   now <- getCurrentTime
   mData <- atomically $ do

src/Server.hs

@@ -34,6 +34,8 @@ import Data.UUID.V4
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Map.Strict as Map
 
+import Database.Persist (Entity(..))
+
 import GHC.Read (readPrec, lexP)
 
 import Jose.Jwa
@@ -99,7 +101,6 @@ type QParam = QueryParam' [Required, Strict]
 
 -- type ProtectedAuth user = BasicAuth "login" user :> "auth" :> Auth -- Prompts for username & password
 -- type QuickAuth = "qauth" :> Auth -- Prompts for username only
-type Foo user userData = BasicAuth "login" user :> "foo" :> Get '[JSON] userData
 type Auth = "auth"
          :> QParam "scope" QScope
          :> QParam "client_id" QClient
@@ -246,7 +247,7 @@ tokenEndpoint = provideToken
 
 
 mkToken :: forall user userData . UserData user userData
-        => user -> [Scope user] -> AuthState user -> IO JWTWrapper
+        => Entity user -> [Scope user] -> AuthState user -> IO JWTWrapper
 mkToken u scopes state = do
   pubKey <- atomically $ readTVar state >>= return . publicKey
   now <- getCurrentTime
@@ -273,7 +274,7 @@ type HeaderR = Header' [Strict, Required]
 type Me userData = Users
                 :> "me"
                 :> HeaderR "Authorization" Text
-                :> Get '[JSON] userData
+                :> Get '[JSON] (Maybe userData)
 
 type UserList userData = Users
                       :> "query"
@@ -284,7 +285,7 @@ type UserList userData = Users
 userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData)
 userEndpoint = handleUserData
   where
-    handleUserData :: Text -> AuthHandler user userData
+    handleUserData :: Text -> AuthHandler user (Maybe userData)
     handleUserData jwtw = do
       let mToken = stripPrefix "Bearer " jwtw
       unless (isJust mToken) . throwError $ err500 { errBody = "Invalid token format"}
@@ -298,7 +299,7 @@ userEndpoint = handleUserData
           liftIO $ print jwt
           mUser <- ask >>= liftIO . (atomically . readTVar >=> return . Map.lookup (jti jwt) . activeTokens)
           case mUser of
-            Just (u, scopes) -> return . mconcat $ map (userScope @user @userData u) scopes
+            Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes
             Nothing -> throwError $ err500 { errBody = "Unknown token" }
       
 
@@ -324,7 +325,6 @@ type Routing user userData = Auth
                         :<|> Token
                         :<|> Me userData
                         :<|> UserList userData
-                        :<|> Foo user userData
                         -- :<|> "qauth" :> Get '[HTML] Html
 
 routing :: forall user userData . UserData user userData => AuthServer user (Routing user userData)
@@ -333,40 +333,33 @@ routing = loginServer @user @userData
      :<|> tokenEndpoint @user @userData
      :<|> userEndpoint @user @userData
      :<|> userListEndpoint @user @userData
-     :<|> undefined
     --  :<|> return (loginPage "/foobar")
 
-exampleAuthServer :: AuthServer User (Routing User (Map.Map Text Text))
-exampleAuthServer = routing
 
 
-authAPI :: Proxy (Routing User (Map.Map Text Text))
-authAPI = Proxy
-
 -- insecureOAuthMock :: Application
 -- insecureOAuthMock = authAPI `serve` exampleAuthServer
 
-insecureOAuthMock' :: [User] -> AuthState User -> Application
+insecureOAuthMock' :: forall user userData . UserData user userData => AuthState user -> Application
-insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler @User @(Map.Map Text Text) s) exampleAuthServer
+insecureOAuthMock' s = serve authAPI $ hoistServer authAPI (toHandler @user @userData s) (routing @user @userData)
   where
-    c = authenticate testUsers :. EmptyContext
+    authAPI = Proxy @(Routing user userData)
-    p = Proxy :: Proxy '[BasicAuthCheck User]
 
-authenticate :: [User] -> BasicAuthCheck User
+-- authenticate :: [User] -> BasicAuthCheck User
-authenticate users = BasicAuthCheck $ \authData -> do
+-- authenticate users = BasicAuthCheck $ \authData -> do
-  let
+--   let
-    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
+--     (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
-  case (find (\u -> email u == uEmail) users) of
+--   case (find (\u -> email u == uEmail) users) of
-    Nothing -> return NoSuchUser
+--     Nothing -> return NoSuchUser
-    Just u  -> return $ if uPass == password u then Authorized u else BadPassword
+--     Just u  -> return $ if uPass == password u then Authorized u else BadPassword
 
 -- frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
 -- frontend ba = client authAPI ba "[ID]" "42" "code" ""
 
-runMockServer :: Int -> [User] -> IO ()
+runMockServer :: forall user userData . UserData user userData => Int -> IO ()
-runMockServer port testUsers = do
+runMockServer port = do
-  state <- mkState @User @(Map.Map Text Text)
+  state <- mkState @user @userData
-  run port $ insecureOAuthMock' testUsers state
+  run port $ insecureOAuthMock' @user @userData state
 
 -- runMockServer' :: Int -> IO ()
 -- runMockServer' port = do

src/User.hs

@@ -24,7 +24,7 @@ class (PersistEntity u, Show u, ToJSON a, Monoid a) => UserData u a where -- TOD
   readScope :: String -> Scope u
   showScope :: Scope u -> String
   userScope  :: Entity u -> Scope u -> a
-  lookupUser :: UserName -> Password -> IO (Maybe u)
+  lookupUser :: UserName -> Password -> IO (Maybe (Entity u))
 
 
 -- data User = User