refactoring to allow more generic use for different user & scope models

src/Server.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings #-}
+{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications #-}
 
 module Server
 ( insecureOAuthMock
@@ -8,6 +8,7 @@ import User
 
 import Control.Monad.IO.Class
 
+import Data.Aeson
 import Data.List (find)
 import Data.Text hiding (find, head, map)
 
@@ -22,27 +23,30 @@ testUsers =
   [ User {name = "TestName", email = "foo@bar.com", uID = "1"}]
 
 
-type Auth = "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe (Map.Map Text Text))
+type Auth userData = "auth" :> QueryParam "scopes" String :> Get '[JSON] (Maybe userData) -- TODO also parametrise "auth" to (auth :: Symbol)
 type Token = "token" :> Post '[JSON] Text -- TODO post jwt token
 -- type Insert = "insert" :> Post '[JSON] User
 
-authServer :: Server Auth
-authServer = handleAuth
+authServer :: forall user userData . UserData user userData => [user] -> Server (Auth userData)
+authServer testUsers = handleAuth
   where
-    handleAuth :: Maybe String -> Handler (Maybe (Map.Map Text Text))
+    handleAuth :: Maybe String -> Handler (Maybe userData)
     handleAuth Nothing = liftIO (putStrLn "no query param given") >> return Nothing
     handleAuth (Just x) = do
       let
-        scopes = read x :: [Scope]
-        userData = mconcat $ map (userScope $ head testUsers) scopes
-      liftIO (putStrLn $ "query param: " ++ show scopes)
-      return $ Just userData
+        scopes = readScopes @user @userData x 
+        ud = mconcat $ map (userScope @user @userData $ head testUsers) scopes
+      liftIO (putStrLn $ "query param: " ++ showScopes @user @userData scopes)
+      return $ Just ud
 
-authAPI :: Proxy Auth
+exampleAuthServer :: Server (Auth (Map.Map Text Text))
+exampleAuthServer = authServer testUsers
+
+authAPI :: Proxy (Auth (Map.Map Text Text))
 authAPI = Proxy
 
 insecureOAuthMock :: Application
-insecureOAuthMock = authAPI `serve` authServer
+insecureOAuthMock = authAPI `serve` exampleAuthServer
 
 tokenEndpoint :: Server Token
 tokenEndpoint = undefined

src/User.hs

@@ -1,10 +1,8 @@
-{-# LANGUAGE DeriveGeneric, OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings, RecordWildCards, TypeFamilies, MultiParamTypeClasses, FlexibleInstances, AllowAmbiguousTypes #-}
 
 module User
-(
-  User (..)
-, Scope (..)
-, userScope
+( UserData(..)
+, User (..)
 ) where
 
 import Data.Aeson
@@ -14,16 +12,24 @@ import Data.Text hiding (singleton)
 import GHC.Generics
 
 
+class (Eq u, ToJSON a, Monoid a) => UserData u a where -- TODO Eq maybe not necessary, but currently needed for TypeApplications
+  data Scope u
+  readScopes :: String -> [Scope u]
+  showScopes :: [Scope u] -> String
+  userScope  :: u -> Scope u -> a
+
+
 data User = User
-  { name  :: Text
-  , email :: Text
-  , uID   :: Text
-  } deriving (Eq, Show, Generic)
+  { name     :: Text
+  , email    :: Text
+  , password :: Text
+  , uID      :: Text
+  } deriving (Eq, Show)
 
-instance ToJSON User
 
-data Scope = ID | Profile deriving (Show, Read, Eq)
-
-userScope :: User -> Scope -> Map Text Text
-userScope User{..} ID = singleton "id" uID
-userScope User{..} Profile = fromList [("name", name), ("email", email)]
+instance UserData User (Map Text Text) where
+  data Scope User = ID | Profile deriving (Show, Read, Eq)
+  readScopes = read
+  showScopes = show
+  userScope User{..} ID = singleton "id" uID
+  userScope User{..} Profile = fromList [("name", name), ("email", email)]