module Servant.API.Auth.Token(
AuthAPI
, AuthSigninMethod
, AuthTouchMethod
, AuthTokenInfoMethod
, AuthSignoutMethod
, AuthSignupMethod
, AuthUsersMethod
, AuthGetUserMethod
, AuthPatchUserMethod
, AuthPutUserMethod
, AuthDeleteUserMethod
, AuthRestoreMethod
, AuthGetGroupMethod
, AuthPostGroupMethod
, AuthPutGroupMethod
, AuthPatchGroupMethod
, AuthDeleteGroupMethod
, AuthGroupsMethod
, authAPI
, authDocs
, Token(..)
, MToken
, TokenHeader
, SimpleToken
, PermsList(..)
, downgradeToken'
, downgradeToken
, UserId
, Login
, Password
, Email
, Permission
, Seconds
, RestoreCode
, ReqRegister(..)
, RespUserInfo(..)
, PatchUser(..)
, RespUsersInfo(..)
, UserGroupId
, UserGroup(..)
, PatchUserGroup(..)
, adminPerm
, registerPerm
, authInfoPerm
, authUpdatePerm
, authDeletePerm
, authOperations
, module Reexport
) where
import Control.Lens
import Data.Aeson.WithField
import Data.Monoid
import Data.Proxy
import Data.Swagger (Swagger, Operation)
import Data.Swagger.Internal (SwaggerType(..), _paramSchemaType)
import Data.Swagger.Internal.ParamSchema
import Data.Swagger.Internal.Schema
import Data.Swagger.Operation
import GHC.Generics
import GHC.TypeLits
import Servant.API
import Servant.Docs
import Servant.Swagger
import Data.Text (Text)
import qualified Data.Text as T
import Servant.API.Auth.Token.Pagination as Reexport
import Servant.API.Auth.Token.Internal.DeriveJson
import Servant.API.Auth.Token.Internal.Schema
newtype Token (perms :: [Symbol]) = Token { unToken :: Text }
deriving (Eq, Show)
instance ToParamSchema (Token perms) where
toParamSchema _ = mempty { _paramSchemaType = SwaggerString }
instance FromHttpApiData (Token perms) where
parseUrlPiece = fmap Token . parseUrlPiece
instance ToHttpApiData (Token perms) where
toUrlPiece = toUrlPiece . unToken
instance ToSample (Token perms) where
toSamples _ = singleSample s
where s = Token "123e4567-e89b-12d3-a456-426655440000"
type SimpleToken = Text
type MToken (perms :: [Symbol]) = Maybe (Token perms)
type Login = Text
type Password = Text
type Email = Text
type Permission = Text
type Seconds = Word
type RestoreCode = Text
type TokenHeader (perms :: [Symbol]) =
Header "Authorization" (Token perms)
type UserId = Word
type UserGroupId = Word
data ReqRegister = ReqRegister {
reqRegLogin :: !Login
, reqRegPassword :: !Password
, reqRegEmail :: !Email
, reqRegPermissions :: ![Permission]
, reqRegGroups :: !(Maybe [UserGroupId])
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "reqReg") ''ReqRegister)
instance ToSchema ReqRegister where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "reqReg"
instance ToSample ReqRegister where
toSamples _ = singleSample s
where
s = ReqRegister {
reqRegLogin = "ncrashed"
, reqRegPassword = "mydogishappy"
, reqRegEmail = "ncrashed@gmail.com"
, reqRegPermissions = ["auth-info", "auth-update"]
, reqRegGroups = Nothing
}
data RespUserInfo = RespUserInfo {
respUserId :: !UserId
, respUserLogin :: !Login
, respUserEmail :: !Email
, respUserPermissions :: ![Permission]
, respUserGroups :: ![UserGroupId]
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "respUser") ''RespUserInfo)
instance ToSchema RespUserInfo where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "respUser"
instance ToSample RespUserInfo where
toSamples _ = singleSample s
where
s = RespUserInfo {
respUserId = 42
, respUserLogin = "ncrashed"
, respUserEmail = "ncrashed@gmail.com"
, respUserPermissions = ["admin"]
, respUserGroups = [0, 1]
}
data RespUsersInfo = RespUsersInfo {
respUsersItems :: ![RespUserInfo]
, respUsersPages :: !Word
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "respUsers") ''RespUsersInfo)
instance ToSchema RespUsersInfo where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "respUsers"
instance ToSample RespUsersInfo where
toSamples _ = singleSample s
where
s = RespUsersInfo [u] 1
u = RespUserInfo {
respUserId = 42
, respUserLogin = "ncrashed"
, respUserEmail = "ncrashed@gmail.com"
, respUserPermissions = ["admin"]
, respUserGroups = [0, 1]
}
data PatchUser = PatchUser {
patchUserLogin :: !(Maybe Login)
, patchUserPassword :: !(Maybe Password)
, patchUserEmail :: !(Maybe Email)
, patchUserPermissions :: !(Maybe [Permission])
, patchUserGroups :: !(Maybe [UserGroupId])
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "patchUser") ''PatchUser)
instance ToSchema PatchUser where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "patchUser"
instance ToSample PatchUser where
toSamples _ = samples [s1, s2, s3]
where
s1 = PatchUser {
patchUserLogin = Just "nusicrashed"
, patchUserPassword = Just "mycatishappy"
, patchUserEmail = Just "ncrashed@mail.ru"
, patchUserPermissions = Just []
, patchUserGroups = Nothing
}
s2 = PatchUser {
patchUserLogin = Nothing
, patchUserPassword = Nothing
, patchUserEmail = Just "ncrashed@mail.ru"
, patchUserPermissions = Nothing
, patchUserGroups = Nothing
}
s3 = PatchUser {
patchUserLogin = Nothing
, patchUserPassword = Just "mycatishappy"
, patchUserEmail = Nothing
, patchUserPermissions = Nothing
, patchUserGroups = Just [1, 2]
}
data UserGroup = UserGroup {
userGroupName :: !Text
, userGroupUsers :: ![UserId]
, userGroupPermissions :: ![Permission]
, userGroupParent :: !(Maybe UserGroupId)
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "userGroup") ''UserGroup)
instance ToSchema UserGroup where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "userGroup"
instance ToSample UserGroup where
toSamples _ = singleSample s
where
s = UserGroup {
userGroupName = "moderators"
, userGroupUsers = [0, 42, 3]
, userGroupPermissions = ["auth-register", "auth-update", "auth-delete"]
, userGroupParent = Nothing
}
data PatchUserGroup = PatchUserGroup {
patchUserGroupName :: !(Maybe Text)
, patchUserGroupUsers :: !(Maybe [UserId])
, patchUserGroupPermissions :: !(Maybe [Permission])
, patchUserGroupParent :: !(Maybe UserGroupId)
, patchUserGroupNoParent :: !(Maybe Bool)
} deriving (Generic, Show)
$(deriveJSON (derivePrefix "patchUserGroup") ''PatchUserGroup)
instance ToSchema PatchUserGroup where
declareNamedSchema = genericDeclareNamedSchema $
schemaOptionsDropPrefix "patchUserGroup"
instance ToSample PatchUserGroup where
toSamples _ = samples [s1, s2, s3]
where
s1 = PatchUserGroup {
patchUserGroupName = Just "developers"
, patchUserGroupUsers = Just [0, 42, 3]
, patchUserGroupPermissions = Just ["program", "eat", "sleep"]
, patchUserGroupParent = Just 2
, patchUserGroupNoParent = Nothing
}
s2 = PatchUserGroup {
patchUserGroupName = Nothing
, patchUserGroupUsers = Nothing
, patchUserGroupPermissions = Just ["program", "sleep"]
, patchUserGroupParent = Nothing
, patchUserGroupNoParent = Nothing
}
s3 = PatchUserGroup {
patchUserGroupName = Nothing
, patchUserGroupUsers = Nothing
, patchUserGroupPermissions = Nothing
, patchUserGroupParent = Nothing
, patchUserGroupNoParent = Just True
}
instance ToParam (QueryParam "login" Login) where
toParam _ = DocQueryParam "login" ["ncrashed", "buddy"] "Any valid login for user" Normal
instance ToParam (QueryParam "password" Password) where
toParam _ = DocQueryParam "password" ["123", "qwerty"] "Any valid password for user" Normal
instance ToParam (QueryParam "expire" Seconds) where
toParam _ = DocQueryParam "expire" ["600", "30"] "Amount of time in seconds the returned token should be valid for, server can restrain maximum token life" Normal
instance ToParam (QueryParam "code" RestoreCode) where
toParam _ = DocQueryParam "code" ["fdfygie", "sdf7230"] "Code that was sended to the user by some secure way" Normal
instance ToCapture (Capture "user-id" UserId) where
toCapture _ = DocCapture "user-id" "unique identifier"
instance ToCapture (Capture "group-id" UserGroupId) where
toCapture _ = DocCapture "group-id" "identifier of a user group"
type AuthAPI =
AuthSigninMethod
:<|> AuthTouchMethod
:<|> AuthTokenInfoMethod
:<|> AuthSignoutMethod
:<|> AuthSignupMethod
:<|> AuthUsersMethod
:<|> AuthGetUserMethod
:<|> AuthPatchUserMethod
:<|> AuthPutUserMethod
:<|> AuthDeleteUserMethod
:<|> AuthRestoreMethod
:<|> AuthGetGroupMethod
:<|> AuthPostGroupMethod
:<|> AuthPutGroupMethod
:<|> AuthPatchGroupMethod
:<|> AuthDeleteGroupMethod
:<|> AuthGroupsMethod
type AuthSigninMethod = "auth" :> "signin"
:> QueryParam "login" Login
:> QueryParam "password" Password
:> QueryParam "expire" Seconds
:> Get '[JSON] (OnlyField "token" SimpleToken)
type AuthTouchMethod = "auth" :> "touch"
:> QueryParam "expire" Seconds
:> TokenHeader '[]
:> Post '[JSON] ()
type AuthTokenInfoMethod = "auth" :> "token"
:> TokenHeader '[]
:> Get '[JSON] RespUserInfo
type AuthSignoutMethod = "auth" :> "signout"
:> TokenHeader '[]
:> Post '[JSON] ()
type AuthSignupMethod = "auth" :> "signup"
:> ReqBody '[JSON] ReqRegister
:> TokenHeader '["auth-register"]
:> Post '[JSON] (OnlyField "user" UserId)
type AuthUsersMethod = "auth" :> "users"
:> PageParam
:> PageSizeParam
:> TokenHeader '["auth-info"]
:> Get '[JSON] RespUsersInfo
type AuthGetUserMethod = "auth" :> "user"
:> Capture "user-id" UserId
:> TokenHeader '["auth-info"]
:> Get '[JSON] RespUserInfo
type AuthPatchUserMethod = "auth" :> "user"
:> Capture "user-id" UserId
:> ReqBody '[JSON] PatchUser
:> TokenHeader '["auth-update"]
:> Patch '[JSON] ()
type AuthPutUserMethod = "auth" :> "user"
:> Capture "user-id" UserId
:> ReqBody '[JSON] ReqRegister
:> TokenHeader '["auth-update"]
:> Put '[JSON] ()
type AuthDeleteUserMethod = "auth" :> "user"
:> Capture "user-id" UserId
:> TokenHeader '["auth-delete"]
:> Delete '[JSON] ()
type AuthRestoreMethod = "auth" :> "restore"
:> Capture "user-id" UserId
:> QueryParam "code" RestoreCode
:> QueryParam "password" Password
:> Post '[JSON] ()
type AuthGetGroupMethod = "auth" :> "group"
:> Capture "group-id" UserGroupId
:> TokenHeader '["auth-info"]
:> Get '[JSON] UserGroup
type AuthPostGroupMethod = "auth" :> "group"
:> ReqBody '[JSON] UserGroup
:> TokenHeader '["auth-update"]
:> Post '[JSON] (OnlyId UserGroupId)
type AuthPutGroupMethod = "auth" :> "group"
:> Capture "group-id" UserGroupId
:> ReqBody '[JSON] UserGroup
:> TokenHeader '["auth-update"]
:> Put '[JSON] ()
type AuthPatchGroupMethod = "auth" :> "group"
:> Capture "group-id" UserGroupId
:> ReqBody '[JSON] PatchUserGroup
:> TokenHeader '["auth-update"]
:> Patch '[JSON] ()
type AuthDeleteGroupMethod = "auth" :> "group"
:> Capture "group-id" UserGroupId
:> TokenHeader '["auth-delete"]
:> Delete '[JSON] ()
type AuthGroupsMethod = "auth" :> "group"
:> PageParam
:> PageSizeParam
:> TokenHeader '["auth-info"]
:> Get '[JSON] (PagedList UserGroupId UserGroup)
authAPI :: Proxy AuthAPI
authAPI = Proxy
adminPerm :: Permission
adminPerm = "admin"
registerPerm :: Permission
registerPerm = "auth-register"
authInfoPerm :: Permission
authInfoPerm = "auth-info"
authUpdatePerm :: Permission
authUpdatePerm = "auth-update"
authDeletePerm :: Permission
authDeletePerm = "auth-delete"
authOperations :: Traversal' Swagger Operation
authOperations = operationsOf $ toSwagger (Proxy :: Proxy AuthAPI)
authDocs :: API
authDocs = docsWith defaultDocOptions [intro] extra (Proxy :: Proxy AuthAPI)
where
intro = DocIntro "Authorisation API by token"
[ "The API provides stateless way to implement authorisation for RESTful APIs. A user of the API get a token once and can query other methods of server only providing the token until it expires."
, "Also the API provides a way to pack users in hierarchy of groups with attached permissions."
]
extra =
mkExtra (Proxy :: Proxy AuthSigninMethod) "How to get a token, missing expire means some default value (server config)"
<> mkExtra (Proxy :: Proxy AuthTouchMethod) "Client cat expand the token lifetime, no permissions are required"
<> mkExtra (Proxy :: Proxy AuthTokenInfoMethod) "Get client info that is binded to the token"
<> mkExtra (Proxy :: Proxy AuthSignoutMethod) "Close session, after call of the method the token in header is not valid."
<> mkExtra (Proxy :: Proxy AuthSignupMethod) "Creation of new user, requires 'registerPerm' for token"
<> mkExtra (Proxy :: Proxy AuthUsersMethod) "Getting list of all users, requires 'authInfoPerm' for token"
<> mkExtra (Proxy :: Proxy AuthGetUserMethod) "Getting info about user, requires 'authInfoPerm' for token"
<> mkExtra (Proxy :: Proxy AuthPatchUserMethod) "Updating login/email/password, requires 'authUpdatePerm' for token"
<> mkExtra (Proxy :: Proxy AuthPutUserMethod) "Replace user with the user in the body, requires 'authUpdatePerm' for token"
<> mkExtra (Proxy :: Proxy AuthDeleteUserMethod) "Delete user from DB, requires 'authDeletePerm' and will cause cascade deletion, that is your usually want"
<> mkExtra (Proxy :: Proxy AuthRestoreMethod) "Generate new password for user. There is two phases, first, the method is called without 'code' parameter. The system sends email with a restore code to user email or sms (its depends on server). After that a call of the method with the code is needed to change password."
<> mkExtra (Proxy :: Proxy AuthGetGroupMethod) "Getting info about user group, requires 'authInfoPerm' for token"
<> mkExtra (Proxy :: Proxy AuthPostGroupMethod) "Inserting new user group, requires 'authUpdatePerm' for token"
<> mkExtra (Proxy :: Proxy AuthPutGroupMethod) "Replace info about given user group, requires 'authUpdatePerm' for token"
<> mkExtra (Proxy :: Proxy AuthPatchGroupMethod) "Patch info about given user group, requires 'authUpdatePerm' for token"
<> mkExtra (Proxy :: Proxy AuthDeleteGroupMethod) "Delete all info about given user group, requires 'authDeletePerm' for token"
<> mkExtra (Proxy :: Proxy AuthGroupsMethod) "Get list of user groups, requires 'authInfoPerm' for token "
mkExtra p s = extraInfo p $
defAction & notes <>~ [ DocNote "Description" [s] ]
instance ToSample Word where
toSamples _ = samples [0, 4, 8, 15, 16, 23, 42]
instance ToSample Text where
toSamples _ = samples ["", "some text", "magic"]
#if MIN_VERSION_servant_docs(0,8,0)
instance ToSample () where
toSamples _ = singleSample ()
#endif
class PermsList (a :: [Symbol]) where
unliftPerms :: forall proxy . proxy a -> [Permission]
instance PermsList '[] where
unliftPerms _ = []
instance (KnownSymbol x, PermsList xs) => PermsList (x ': xs) where
unliftPerms _ = T.pack (symbolVal (Proxy :: Proxy x))
: unliftPerms (Proxy :: Proxy xs)
type family ContainPerm (a :: [Symbol]) (b :: Symbol) where
ContainPerm '[] b = 'False
ContainPerm (a ': as) a = 'True
ContainPerm (a ': as) b = ContainPerm as b
type family ConatinAllPerm (a :: [Symbol]) (b :: [Symbol]) where
ConatinAllPerm '[] bs = '[]
ConatinAllPerm (a ': as) bs = (ContainPerm bs a) ': (ConatinAllPerm as bs)
type family TAll (a :: [Bool]) :: Bool where
TAll '[] = 'True
TAll ('True ': as) = TAll as
TAll ('False ': as) = 'False
type PermsSubset (a :: [Symbol]) (b :: [Symbol]) = TAll (ConatinAllPerm a b)
downgradeToken' :: 'True ~ PermsSubset ts' ts => Token ts -> Token ts'
downgradeToken' = Token . unToken
downgradeToken :: 'True ~ PermsSubset ts' ts => MToken ts -> MToken ts'
downgradeToken = fmap downgradeToken'