servant-auth-token-api 0.3.1.0 → 0.3.2.0

raw patch · 3 files changed

+153/−113 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• servant-auth-token-api.cabal +13/−5
• src/Servant/API/Auth/Token.hs +135/−108

@@ -1,3 +1,8 @@+0.3.2.0+=======++* Add `flat-perm-symbols` flag.+ 0.3.1.0 ======= 

@@ -1,5 +1,5 @@ name:                servant-auth-token-api-version:             0.3.1.0+version:             0.3.2.0 synopsis:            Servant based API for token based authorisation description:         Please see README.md homepage:            https://github.com/ncrashed/servant-auth-token-api#readme@@ -15,14 +15,18 @@   CHANGELOG.md cabal-version:       >=1.10 +Flag flat-perm-symbols+  Description: Use flat Symbols for token tags, improve compilation time.+  Default: False+ library   hs-source-dirs:      src-  exposed-modules:     -    Servant.API.Auth.Token +  exposed-modules:+    Servant.API.Auth.Token     Servant.API.Auth.Token.Pagination     Servant.API.Auth.Token.Internal.DeriveJson     Servant.API.Auth.Token.Internal.Schema-  build-depends:       +  build-depends:       base >= 4.7 && < 5     , aeson >= 0.11 && < 0.12     , aeson-injector >= 1.0.4 && < 1.1@@ -33,9 +37,10 @@     , servant-swagger >= 1.0 && < 2     , swagger2 >= 2.0 && <= 3     , text >= 1.2 && < 2-    +   default-language:    Haskell2010   default-extensions:+    CPP     DataKinds     DeriveGeneric     FlexibleInstances@@ -47,6 +52,9 @@     TypeFamilies     TypeOperators     TypeSynonymInstances++  if flag(flat-perm-symbols)+    cpp-options:   -DFLAT_SYMBOLS  source-repository head   type:     git

@@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-}+#ifdef FLAT_SYMBOLS+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE UndecidableInstances #-}+#endif {-# OPTIONS_GHC -fno-warn-orphans #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}@@ -40,7 +44,11 @@   , authAPI   , authDocs   -- ** Permission symbol+#ifdef FLAT_SYMBOLS+  , PermSymbol+#else   , PermSymbol(..)+#endif   , UnliftPermSymbol(..)   , PermsList(..)   , PlainPerms@@ -79,56 +87,75 @@   , authDeletePerm   -- * Swagger helpers   , authOperations-  ) where +  ) where  import Control.Lens import Data.Aeson.Unit-import Data.Aeson.WithField  -import Data.Monoid +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.Generics import GHC.TypeLits import Servant.API-import Servant.Docs +import Servant.Docs import Servant.Swagger import Text.RawString.QQ  import Data.Text (Text)-import qualified Data.Text as T +import qualified Data.Text as T  import Servant.API.Auth.Token.Pagination-import Servant.API.Auth.Token.Internal.DeriveJson +import Servant.API.Auth.Token.Internal.DeriveJson import Servant.API.Auth.Token.Internal.Schema -instance ToSample Unit where +instance ToSample Unit where   toSamples _ = singleSample Unit --- | Type level permission type that allows to +-- Simplified version that doesn't consume GBs of RAM+#ifdef FLAT_SYMBOLS+-- | Type level permission type that is simple 'Symbol' tag+type {- kind -} PermSymbol = Symbol++-- | Convertation of permission symbol into runtime string+class UnliftPermSymbol (s :: PermSymbol) where+  unliftPermSymbol :: Proxy s -> String++instance KnownSymbol s => UnliftPermSymbol s where+  unliftPermSymbol _ = symbolVal (Proxy :: Proxy s)++-- | Helper type family to wrap all symbols, with flat symbols this is id+-- function+type family PlainPerms (p :: [Symbol]) :: [PermSymbol] where+  PlainPerms a = a++#else+-- | Type level permission type that allows to -- construct complex permission labels-data {- kind -} PermSymbol = -    PermLabel Symbol +data {- kind -} PermSymbol =+    PermLabel Symbol   | PermConcat PermSymbol PermSymbol  -- | Convertation of permission symbol into runtim string-class UnliftPermSymbol (s :: PermSymbol) where -  unliftPermSymbol :: Proxy s -> String +class UnliftPermSymbol (s :: PermSymbol) where+  unliftPermSymbol :: Proxy s -> String -instance KnownSymbol s => UnliftPermSymbol ('PermLabel s) where +instance KnownSymbol s => UnliftPermSymbol ('PermLabel s) where   unliftPermSymbol _ = symbolVal (Proxy :: Proxy s) -instance (UnliftPermSymbol p1, UnliftPermSymbol p2) => UnliftPermSymbol ('PermConcat p1 p2) where +instance (UnliftPermSymbol p1, UnliftPermSymbol p2) => UnliftPermSymbol ('PermConcat p1 p2) where   unliftPermSymbol _ = unliftPermSymbol (Proxy :: Proxy p1)     ++ unliftPermSymbol (Proxy :: Proxy p2)  -- | Helper type family to wrap all symbols into 'PermLabel'-type family PlainPerms (p :: [Symbol]) :: [PermSymbol] where +type family PlainPerms (p :: [Symbol]) :: [PermSymbol] where   PlainPerms '[] = '[]   PlainPerms (s ': ss) = 'PermLabel s ': PlainPerms ss+#endif  -- | Token is simple string marked by permissions that are expected -- from the token to pass guarding functions.@@ -141,13 +168,13 @@ -- Simplified version that takes plain symbols as permissions. type Token' (perms :: [Symbol]) = Token (PlainPerms perms) -instance ToParamSchema (Token perms) where +instance ToParamSchema (Token perms) where   toParamSchema _ = mempty { _paramSchemaType = SwaggerString } -instance FromHttpApiData (Token perms) where +instance FromHttpApiData (Token perms) where   parseUrlPiece = fmap Token . parseUrlPiece -instance ToHttpApiData (Token perms) where +instance ToHttpApiData (Token perms) where   toUrlPiece = toUrlPiece . unToken  instance ToSample (Token perms) where@@ -155,7 +182,7 @@     where s = Token "123e4567-e89b-12d3-a456-426655440000"  -- | Token that doesn't have attached compile-time permissions-type SimpleToken = Text +type SimpleToken = Text -- | Shortcut for Maybe Token with attached permissions type MToken (perms :: [PermSymbol]) = Maybe (Token perms) @@ -165,55 +192,55 @@ type MToken' (perms :: [Symbol]) = MToken (PlainPerms perms)  -- | User name for login-type Login = Text +type Login = Text -- | Password for login type Password = Text -- | User email-type Email = Text +type Email = Text -- | Special tag for a permission that a user has-type Permission = Text +type Permission = Text -- | Amount of seconds type Seconds = Word--- | Special tag for password restore -type RestoreCode = Text +-- | Special tag for password restore+type RestoreCode = Text -- | Single use code used for authorisation via 'AuthSigninGetCodeMethod' and -- 'AuthSigninPostCodeMethod' endpoints-type SingleUseCode = Text +type SingleUseCode = Text --- | Token header that we require for authorization marked +-- | Token header that we require for authorization marked -- by permissions that are expected from the token to pass guarding functions.-type TokenHeader (perms :: [PermSymbol]) = +type TokenHeader (perms :: [PermSymbol]) =   Header "Authorization" (Token perms) --- | Token header that we require for authorization marked +-- | Token header that we require for authorization marked -- by permissions that are expected from the token to pass guarding functions. -- -- Simplified version that takes plain symbols as permissions. type TokenHeader' (perms :: [Symbol]) = TokenHeader (PlainPerms perms)  -- | Id of user that is used in the API-type UserId = Word +type UserId = Word  -- | Id of user group-type UserGroupId = Word +type UserGroupId = Word  -- | Request body for user registration data ReqRegister = ReqRegister {-  reqRegLogin :: !Login -, reqRegPassword :: !Password -, reqRegEmail :: !Email +  reqRegLogin :: !Login+, reqRegPassword :: !Password+, reqRegEmail :: !Email , reqRegPermissions :: ![Permission] , reqRegGroups :: !(Maybe [UserGroupId]) } deriving (Generic, Show) $(deriveJSON (derivePrefix "reqReg") ''ReqRegister) -instance ToSchema ReqRegister where +instance ToSchema ReqRegister where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "reqReg"  instance ToSample ReqRegister where   toSamples _ = singleSample s-    where +    where     s = ReqRegister {         reqRegLogin = "ncrashed"       , reqRegPassword = "mydogishappy"@@ -225,20 +252,20 @@ -- | Response with user info data RespUserInfo = RespUserInfo {   respUserId :: !UserId-, respUserLogin :: !Login -, respUserEmail :: !Email +, respUserLogin :: !Login+, respUserEmail :: !Email , respUserPermissions :: ![Permission] , respUserGroups :: ![UserGroupId] } deriving (Generic, Show) $(deriveJSON (derivePrefix "respUser") ''RespUserInfo) -instance ToSchema RespUserInfo where +instance ToSchema RespUserInfo where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "respUser"  instance ToSample RespUserInfo where   toSamples _ = singleSample s-    where +    where     s = RespUserInfo {         respUserId = 42       , respUserLogin = "ncrashed"@@ -250,17 +277,17 @@ -- | Response with users info and pagination data RespUsersInfo = RespUsersInfo {   respUsersItems :: ![RespUserInfo]-, respUsersPages :: !Word +, respUsersPages :: !Word } deriving (Generic, Show) $(deriveJSON (derivePrefix "respUsers") ''RespUsersInfo) -instance ToSchema RespUsersInfo where +instance ToSchema RespUsersInfo where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "respUsers"  instance ToSample RespUsersInfo where   toSamples _ = singleSample s-    where +    where     s = RespUsersInfo [u] 1     u = RespUserInfo {         respUserId = 42@@ -280,13 +307,13 @@ } deriving (Generic, Show) $(deriveJSON (derivePrefix "patchUser") ''PatchUser) -instance ToSchema PatchUser where +instance ToSchema PatchUser where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "patchUser"  instance ToSample PatchUser where   toSamples _ = samples [s1, s2, s3]-    where +    where     s1 = PatchUser {         patchUserLogin = Just "nusicrashed"       , patchUserPassword = Just "mycatishappy"@@ -314,20 +341,20 @@ -- -- Also a group hierarchy can be formed. data UserGroup = UserGroup {-  userGroupName :: !Text +  userGroupName :: !Text , userGroupUsers :: ![UserId] , userGroupPermissions :: ![Permission] , userGroupParent :: !(Maybe UserGroupId) } deriving (Generic, Show) $(deriveJSON (derivePrefix "userGroup") ''UserGroup) -instance ToSchema UserGroup where +instance ToSchema UserGroup where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "userGroup"  instance ToSample UserGroup where   toSamples _ = singleSample s-    where +    where     s = UserGroup {         userGroupName = "moderators"       , userGroupUsers = [0, 42, 3]@@ -346,13 +373,13 @@ } deriving (Generic, Show) $(deriveJSON (derivePrefix "patchUserGroup") ''PatchUserGroup) -instance ToSchema PatchUserGroup where +instance ToSchema PatchUserGroup where   declareNamedSchema = genericDeclareNamedSchema $     schemaOptionsDropPrefix "patchUserGroup"  instance ToSample PatchUserGroup where   toSamples _ = samples [s1, s2, s3]-    where +    where     s1 = PatchUserGroup {         patchUserGroupName = Just "developers"       , patchUserGroupUsers = Just [0, 42, 3]@@ -414,7 +441,7 @@   :<|> AuthDeleteGroupMethod   :<|> AuthGroupsMethod --- | How to get a token, expire of 'Nothing' means +-- | How to get a token, expire of 'Nothing' means -- some default value (server config). -- -- Logic of authorisation via this method is:@@ -434,15 +461,15 @@ -- -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. type AuthSigninMethod = "auth" :> "signin"-  :> QueryParam "login" Login -  :> QueryParam "password" Password +  :> QueryParam "login" Login+  :> QueryParam "password" Password   :> QueryParam "expire" Seconds   :> Get '[JSON] (OnlyField "token" SimpleToken)  -- | Authorisation via code of single usage. -- -- Logic of authorisation via this method is:--- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via@@ -462,13 +489,13 @@ -- -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. type AuthSigninGetCodeMethod = "auth" :> "signin" :> "code"-  :> QueryParam "login" Login +  :> QueryParam "login" Login   :> Get '[JSON] Unit  -- | Authorisation via code of single usage. -- -- Logic of authorisation via this method is:--- +-- -- * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint -- -- * Server generates single use token and sends it via@@ -488,13 +515,13 @@ -- -- * Client can get info about user with 'AuthTokenInfoMethod' endpoint. type AuthSigninPostCodeMethod = "auth" :> "signin" :> "code"-  :> QueryParam "login" Login +  :> QueryParam "login" Login   :> QueryParam "code" SingleUseCode   :> QueryParam "expire" Seconds   :> Post '[JSON] (OnlyField "token" SimpleToken)  -- | Client cat expand the token lifetime, no permissions are required-type AuthTouchMethod = "auth" :> "touch" +type AuthTouchMethod = "auth" :> "touch"   :> QueryParam "expire" Seconds   :> TokenHeader '[]   :> Post '[JSON] Unit@@ -525,20 +552,20 @@  -- | Getting info about user, requires 'authInfoPerm' for token type AuthGetUserMethod = "auth" :> "user"-  :> Capture "user-id" UserId +  :> Capture "user-id" UserId   :> TokenHeader' '["auth-info"]   :> Get '[JSON] RespUserInfo  -- | Updating login/email/password, requires 'authUpdatePerm' for token type AuthPatchUserMethod = "auth" :> "user"-  :> Capture "user-id" UserId +  :> Capture "user-id" UserId   :> ReqBody '[JSON] PatchUser   :> TokenHeader' '["auth-update"]   :> Patch '[JSON] Unit  -- | Replace user with the user in the body, requires 'authUpdatePerm' for token type AuthPutUserMethod = "auth" :> "user"-  :> Capture "user-id" UserId +  :> Capture "user-id" UserId   :> ReqBody '[JSON] ReqRegister   :> TokenHeader' '["auth-update"]   :> Put '[JSON] Unit@@ -546,21 +573,21 @@ -- | Delete user from DB, requires 'authDeletePerm' and will cause cascade -- deletion, that is your usually want type AuthDeleteUserMethod = "auth" :> "user"-  :> Capture "user-id" UserId +  :> Capture "user-id" UserId   :> TokenHeader' '["auth-delete"]   :> Delete '[JSON] Unit  -- | 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 +-- to user email or sms (its depends on server). After that a call of the method -- with the code is needed to change password.-type AuthRestoreMethod = "auth" :> "restore" +type AuthRestoreMethod = "auth" :> "restore"   :> Capture "user-id" UserId-  :> QueryParam "code" RestoreCode -  :> QueryParam "password" Password +  :> QueryParam "code" RestoreCode+  :> QueryParam "password" Password   :> Post '[JSON] Unit --- | Generate single usage codes that user can write down and use later for emergency +-- | Generate single usage codes that user can write down and use later for emergency -- authorisation. -- -- 'Nothing' for "codes-count" parameter means some default value defined by server. Server@@ -574,7 +601,7 @@ -- See also: 'AuthSigninPostCodeMethod' for utilisation of the codes. type AuthGetSingleUseCodes = "auth" :> "codes"   :> Capture "user-id" UserId-  :> QueryParam "codes-count" Word +  :> QueryParam "codes-count" Word   :> TokenHeader' '["auth-single-codes"]   :> Get '[JSON] (OnlyField "codes" [SingleUseCode]) @@ -610,16 +637,16 @@   :> TokenHeader' '["auth-delete"]   :> Delete '[JSON] Unit --- | Get list of user groups, requires 'authInfoPerm' for token +-- | Get list of user groups, requires 'authInfoPerm' for token type AuthGroupsMethod = "auth" :> "group"   :> PageParam   :> PageSizeParam   :> TokenHeader' '["auth-info"]   :> Get '[JSON] (PagedList UserGroupId UserGroup) --- | Proxy type for auth API, used to pass the type-level info into +-- | Proxy type for auth API, used to pass the type-level info into -- client/docs generation functions-authAPI :: Proxy AuthAPI +authAPI :: Proxy AuthAPI authAPI = Proxy  -- | Permission that allows everything by default@@ -631,11 +658,11 @@ registerPerm = "auth-register"  -- | Permission that allows to query info about other users-authInfoPerm :: Permission +authInfoPerm :: Permission authInfoPerm = "auth-info"  -- | Permission that allows to update fields of an user-authUpdatePerm :: Permission +authUpdatePerm :: Permission authUpdatePerm = "auth-update"  -- | Permission that allows to delete users and cause cascade deletion@@ -649,12 +676,12 @@ -- | "Servant.Docs" documentation of the Auth API authDocs :: API authDocs = docsWith defaultDocOptions [intro] extra (Proxy :: Proxy AuthAPI)-  where +  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 = +  extra =        mkExtra' (Proxy :: Proxy AuthSigninMethod) ["How to get a token, missing expire means some default value (server config).", simpleAuthDescr]     <> mkExtra' (Proxy :: Proxy AuthSigninGetCodeMethod) ["Authorisation via codes of single usage, that are sended to user via different channel of communication.", singleUseAuthDescr]     <> mkExtra' (Proxy :: Proxy AuthSigninPostCodeMethod) ["Authorisation via codes of single usage, that are sended to user via different channel of communication.", singleUseAuthDescr]@@ -676,9 +703,9 @@     <> 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 $  +  mkExtra p s = extraInfo p $     defAction & notes <>~ [ DocNote "Description" [s] ]-  mkExtra' p ss = extraInfo p $  +  mkExtra' p ss = extraInfo p $     defAction & notes <>~ [ DocNote "Description" ss ]    simpleAuthDescr = [r|@@ -686,96 +713,96 @@      * Client sends GET request to the endpoint with     user specified login and password and optional expire-   +     * Server responds with token or error-   +     * Client uses the token with other requests as authorisation     header-   +     * Client can extend lifetime of token by periodically pinging     of 'AuthTouchMethod' endpoint-   +     * Client can invalidate token instantly by 'AuthSignoutMethod'-   +     * Client can get info about user with 'AuthTokenInfoMethod' endpoint.     |]    singleUseAuthDescr = [r|     Logic of authorisation via single use code method is:-    +     * Client sends GET request to 'AuthSigninGetCodeMethod' endpoint-   +     * Server generates single use token and sends it via       SMS or email (server specific implementation)-   +     * Client sends POST request to 'AuthSigninPostCodeMethod' endpoint-   +     * Server responds with auth token.-   +     * Client uses the token with other requests as authorisation     header-   +     * Client can extend lifetime of token by periodically pinging     of 'AuthTouchMethod' endpoint-   +     * Client can invalidate token instantly by 'AuthSignoutMethod'-   +     * Client can get info about user with 'AuthTokenInfoMethod' endpoint.     |]    authGetSingleUseCodesDescr = [r|-    Generate single usage codes that user can write down and use later for emergency +    Generate single usage codes that user can write down and use later for emergency     authorisation.-   +     'Nothing' for "codes-count" parameter means some default value defined by server. Server     can restrict maximum count of such codes.-   +     Server should invalidate previous codes on subsequent calls of the endpoint.-   +     Special authorisation tag can be used to disable the feature, merely don't give     the tag to users and they won't be able to generate codes.-   +     See also: 'AuthSigninPostCodeMethod' for utilisation of the codes.     |] -instance ToSample Word where +instance ToSample Word where   toSamples _ = samples [0, 4, 8, 15, 16, 23, 42] -instance ToSample Text where +instance ToSample Text where   toSamples _ = samples ["", "some text", "magic"]  #if MIN_VERSION_servant_docs(0,8,0)-instance ToSample () where +instance ToSample () where   toSamples _ = singleSample () #endif  -- | Unlifting compile-time permissions into list of run-time permissions-class PermsList (a :: [PermSymbol]) where +class PermsList (a :: [PermSymbol]) where   unliftPerms :: forall proxy . proxy a -> [Permission] -instance PermsList '[] where +instance PermsList '[] where   unliftPerms _ = [] -instance (UnliftPermSymbol x, PermsList xs) => PermsList (x ': xs) where +instance (UnliftPermSymbol x, PermsList xs) => PermsList (x ': xs) where   unliftPerms _ = T.pack (unliftPermSymbol (Proxy :: Proxy x))     : unliftPerms (Proxy :: Proxy xs)  -- | Check whether a 'b' is contained in permission list of 'a'-type family ContainPerm (a :: [PermSymbol]) (b :: PermSymbol) where +type family ContainPerm (a :: [PermSymbol]) (b :: PermSymbol) where   ContainPerm '[] b = 'False   ContainPerm (a ': as) a = 'True   ContainPerm (a ': as) b = ContainPerm as b  -- | Check that first set of permissions is subset of second-type family ConatinAllPerm (a :: [PermSymbol]) (b :: [PermSymbol]) where +type family ConatinAllPerm (a :: [PermSymbol]) (b :: [PermSymbol]) where   ConatinAllPerm '[] bs = '[]   ConatinAllPerm (a ': as) bs = (ContainPerm bs a) ': (ConatinAllPerm as bs)  -- | Foldl type level list of bools, identicall to 'and'-type family TAll (a :: [Bool]) :: Bool where +type family TAll (a :: [Bool]) :: Bool where   TAll '[] = 'True-  TAll ('True ': as) = TAll as -  TAll ('False ': as) = 'False +  TAll ('True ': as) = TAll as+  TAll ('False ': as) = 'False  -- | Check that first set of permissions is subset of second, throw error if not type PermsSubset (a :: [PermSymbol]) (b :: [PermSymbol]) = TAll (ConatinAllPerm a b)@@ -783,8 +810,8 @@ -- | Cast token to permissions that are lower than original one -- -- The cast is safe, the permissions are cheked on compile time.-downgradeToken' :: 'True ~ PermsSubset ts' ts => Token ts -> Token ts' -downgradeToken' = Token . unToken +downgradeToken' :: 'True ~ PermsSubset ts' ts => Token ts -> Token ts'+downgradeToken' = Token . unToken  -- | Cast token to permissions that are lower than original one. --