servant-auth-token-api (empty) → 0.1.0.0
raw patch · 7 files changed
+816/−0 lines, 7 filesdep +aesondep +aeson-injectordep +basesetup-changed
Dependencies added: aeson, aeson-injector, base, lens, servant, servant-docs, servant-swagger, swagger2, text
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- servant-auth-token-api.cabal +49/−0
- src/Servant/API/Auth/Token.hs +576/−0
- src/Servant/API/Auth/Token/Internal/DeriveJson.hs +52/−0
- src/Servant/API/Auth/Token/Internal/Schema.hs +42/−0
- src/Servant/API/Auth/Token/Pagination.hs +65/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Anton Gushcha (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of NCrashed nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ servant-auth-token-api.cabal view
@@ -0,0 +1,49 @@+name: servant-auth-token-api+version: 0.1.0.0+synopsis: Servant based API for token based authorisation+description: Please see README.md+homepage: https://github.com/ncrashed/servant-auth-token-api#readme+license: BSD3+license-file: LICENSE+author: NCrashed+maintainer: ncrashed@gmail.com+copyright: 2016 Anton Gushcha+category: Web+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ 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: + base >= 4.7 && < 5+ , aeson >= 0.11 && < 0.12+ , lens >= 4.13 && < 5+ , aeson-injector >= 1.0.3 && < 1.1+ , swagger2 >= 2.0 && <= 3+ , servant >= 0.7 && < 0.9+ , servant-swagger >= 1.0 && < 2+ , servant-docs >= 0.7 && < 0.9+ , text >= 1.2 && < 2+ default-language: Haskell2010+ default-extensions:+ DataKinds+ DeriveGeneric+ FlexibleInstances+ GeneralizedNewtypeDeriving+ KindSignatures+ OverloadedStrings+ RankNTypes+ ScopedTypeVariables+ TypeFamilies+ TypeOperators+ TypeSynonymInstances++source-repository head+ type: git+ location: https://github.com/ncrashed/servant-auth-token-api
+ src/Servant/API/Auth/Token.hs view
@@ -0,0 +1,576 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Servant.API.Auth.Token+Description : API for token based authorisation.+Copyright : (c) Anton Gushcha, 2016+License : MIT+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : Portable+-}+module Servant.API.Auth.Token(+ -- * API specs+ AuthAPI+ , AuthSigninMethod+ , AuthTouchMethod+ , AuthTokenInfoMethod+ , AuthSignoutMethod+ , AuthSignupMethod+ , AuthUsersMethod+ , AuthGetUserMethod+ , AuthPatchUserMethod+ , AuthPutUserMethod+ , AuthDeleteUserMethod+ , AuthRestoreMethod+ , AuthGetGroupMethod+ , AuthPostGroupMethod+ , AuthPutGroupMethod+ , AuthPatchGroupMethod+ , AuthDeleteGroupMethod+ , AuthGroupsMethod+ , authAPI+ , authDocs+ -- ** Token+ , Token(..)+ , MToken+ , TokenHeader+ , SimpleToken+ , PermsList(..)+ , downgradeToken'+ , downgradeToken+ -- ** User+ , UserId+ , Login+ , Password+ , Email+ , Permission+ , Seconds+ , RestoreCode+ , ReqRegister(..)+ , RespUserInfo(..)+ , PatchUser(..)+ , RespUsersInfo(..)+ -- ** User groups+ , UserGroupId+ , UserGroup(..)+ , PatchUserGroup(..)+ -- ** Default permissions+ , adminPerm+ , registerPerm+ , authInfoPerm+ , authUpdatePerm+ , authDeletePerm+ -- * Swagger helpers+ , authOperations+ -- * Reexports+ , 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++-- | Token is simple string marked by permissions that are expected+-- from the token to pass guarding functions.+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"++-- | Token that doesn't have attached compile-time permissions+type SimpleToken = Text +-- | Shortcut for Maybe Token with attached permissions+type MToken (perms :: [Symbol]) = Maybe (Token perms)++-- | User name for login+type Login = Text +-- | Password for login+type Password = Text+-- | User email+type Email = Text +-- | Special tag for a permission that a user has+type Permission = Text +-- | Amount of seconds+type Seconds = Word+-- | Special tag for password restore +type RestoreCode = Text ++-- | Token header that we require for authorization marked +-- by permissions that are expected from the token to pass guarding functions.+type TokenHeader (perms :: [Symbol]) = + Header "Authorization" (Token perms)++-- | Id of user that is used in the API+type UserId = Word ++-- | Id of user group+type UserGroupId = Word ++-- | Request body for user registration+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+ }++-- | Response with user info+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]+ }++-- | Response with users info and pagination+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]+ }++-- | Request body for patching user+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 of user group, groups allows to group permissions+-- and assign them to particular users in batch manner.+--+-- Also a group hierarchy can be formed.+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 type that is used to patch 'UserGroup'+data PatchUserGroup = PatchUserGroup {+ patchUserGroupName :: !(Maybe Text)+, patchUserGroupUsers :: !(Maybe [UserId])+, patchUserGroupPermissions :: !(Maybe [Permission])+, patchUserGroupParent :: !(Maybe UserGroupId)+-- | Special case when you want to set parent to 'Nothing'+, 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"++-- | Generic authorization API+type AuthAPI =+ AuthSigninMethod+ :<|> AuthTouchMethod+ :<|> AuthTokenInfoMethod+ :<|> AuthSignoutMethod+ :<|> AuthSignupMethod+ :<|> AuthUsersMethod+ :<|> AuthGetUserMethod+ :<|> AuthPatchUserMethod+ :<|> AuthPutUserMethod+ :<|> AuthDeleteUserMethod+ :<|> AuthRestoreMethod+ :<|> AuthGetGroupMethod+ :<|> AuthPostGroupMethod+ :<|> AuthPutGroupMethod+ :<|> AuthPatchGroupMethod+ :<|> AuthDeleteGroupMethod+ :<|> AuthGroupsMethod++-- | How to get a token, expire of 'Nothing' means +-- some default value (server config)+type AuthSigninMethod = "auth" :> "signin"+ :> QueryParam "login" Login + :> QueryParam "password" Password + :> QueryParam "expire" Seconds+ :> Get '[JSON] (OnlyField "token" SimpleToken)++-- | Client cat expand the token lifetime, no permissions are required+type AuthTouchMethod = "auth" :> "touch" + :> QueryParam "expire" Seconds+ :> TokenHeader '[]+ :> Post '[JSON] ()++-- | Get client info that is binded to the token+type AuthTokenInfoMethod = "auth" :> "token"+ :> TokenHeader '[]+ :> Get '[JSON] RespUserInfo++-- | Close session, after call of the method the+-- token in header is not valid.+type AuthSignoutMethod = "auth" :> "signout"+ :> TokenHeader '[]+ :> Post '[JSON] ()++-- | Creation of new user, requires 'registerPerm' for token+type AuthSignupMethod = "auth" :> "signup"+ :> ReqBody '[JSON] ReqRegister+ :> TokenHeader '["auth-register"]+ :> Post '[JSON] (OnlyField "user" UserId)++-- | Getting list of all users, requires 'authInfoPerm' for token+type AuthUsersMethod = "auth" :> "users"+ :> PageParam+ :> PageSizeParam+ :> TokenHeader '["auth-info"]+ :> Get '[JSON] RespUsersInfo++-- | Getting info about user, requires 'authInfoPerm' for token+type AuthGetUserMethod = "auth" :> "user"+ :> 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 + :> ReqBody '[JSON] PatchUser+ :> TokenHeader '["auth-update"]+ :> Patch '[JSON] ()++-- | Replace user with the user in the body, requires 'authUpdatePerm' for token+type AuthPutUserMethod = "auth" :> "user"+ :> Capture "user-id" UserId + :> ReqBody '[JSON] ReqRegister+ :> TokenHeader '["auth-update"]+ :> Put '[JSON] ()++-- | Delete user from DB, requires 'authDeletePerm' and will cause cascade+-- deletion, that is your usually want+type AuthDeleteUserMethod = "auth" :> "user"+ :> Capture "user-id" UserId + :> TokenHeader '["auth-delete"]+ :> Delete '[JSON] ()++-- | 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.+type AuthRestoreMethod = "auth" :> "restore" + :> Capture "user-id" UserId+ :> QueryParam "code" RestoreCode + :> QueryParam "password" Password + :> Post '[JSON] ()++-- | Getting info about user group, requires 'authInfoPerm' for token+type AuthGetGroupMethod = "auth" :> "group"+ :> Capture "group-id" UserGroupId+ :> TokenHeader '["auth-info"]+ :> Get '[JSON] UserGroup++-- | Inserting new user group, requires 'authUpdatePerm' for token+type AuthPostGroupMethod = "auth" :> "group"+ :> ReqBody '[JSON] UserGroup+ :> TokenHeader '["auth-update"]+ :> Post '[JSON] (OnlyId UserGroupId)++-- | Replace info about given user group, requires 'authUpdatePerm' for token+type AuthPutGroupMethod = "auth" :> "group"+ :> Capture "group-id" UserGroupId+ :> ReqBody '[JSON] UserGroup+ :> TokenHeader '["auth-update"]+ :> Put '[JSON] ()++-- | Patch info about given user group, requires 'authUpdatePerm' for token+type AuthPatchGroupMethod = "auth" :> "group"+ :> Capture "group-id" UserGroupId+ :> ReqBody '[JSON] PatchUserGroup+ :> TokenHeader '["auth-update"]+ :> Patch '[JSON] ()++-- | Delete all info about given user group, requires 'authDeletePerm' for token+type AuthDeleteGroupMethod = "auth" :> "group"+ :> Capture "group-id" UserGroupId+ :> TokenHeader '["auth-delete"]+ :> Delete '[JSON] ()++-- | 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 +-- client/docs generation functions+authAPI :: Proxy AuthAPI +authAPI = Proxy++-- | Permission that allows everything by default+adminPerm :: Permission+adminPerm = "admin"++-- | Permission that allows registration of new users+registerPerm :: Permission+registerPerm = "auth-register"++-- | Permission that allows to query info about other users+authInfoPerm :: Permission +authInfoPerm = "auth-info"++-- | Permission that allows to update fields of an user+authUpdatePerm :: Permission +authUpdatePerm = "auth-update"++-- | Permission that allows to delete users and cause cascade deletion+authDeletePerm :: Permission+authDeletePerm = "auth-delete"++-- | Select only operations of the Auth API+authOperations :: Traversal' Swagger Operation+authOperations = operationsOf $ toSwagger (Proxy :: Proxy AuthAPI)++-- | "Servant.Docs" documentation of the Auth API+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)++-- | Check whether a 'b' is contained in permission list of 'a'+type family ContainPerm (a :: [Symbol]) (b :: Symbol) 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 :: [Symbol]) (b :: [Symbol]) 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 + TAll '[] = 'True+ 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 :: [Symbol]) (b :: [Symbol]) = TAll (ConatinAllPerm a b)++-- | 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 ++-- | 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 => MToken ts -> MToken ts'+downgradeToken = fmap downgradeToken'
+ src/Servant/API/Auth/Token/Internal/DeriveJson.hs view
@@ -0,0 +1,52 @@+{-|+Module : Servant.API.Auth.Token.Internal.DeriveJson+Description : Helpers for aeson deriving without name prefixes.+Copyright : (c) Anton Gushcha, 2016+License : MIT+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : Portable++Common usage:++> data PagedList i a = PagedList {+> pagedListItems :: ![a] -- ^ Payload+> , pagedListPages :: !Word -- ^ Count of available pages+> } deriving (Generic, Show)+> +> $(deriveJSON (derivePrefix "pagedList") ''PagedList)++It will work with the following jsons:++> { "items": [], "pages": 0 }++-}+module Servant.API.Auth.Token.Internal.DeriveJson(+ derivePrefix+ , deriveJSON+ ) where ++import Data.Aeson.TH as TH+import Data.Char as C +import Data.Text (Text)++import qualified Data.Text as T++-- | For aeson deriving, drop prefix t and map to lower+derivePrefix :: Text -> TH.Options+derivePrefix t = defaultOptions {+ fieldLabelModifier = mapFirst C.toLower . drop (T.length t) + , constructorTagModifier = camelCaseToDash+ }++mapFirst :: (a -> a) -> [a] -> [a]+mapFirst f cs = case cs of + [] -> []+ (x:xs) -> f x : xs ++camelCaseToDash :: String -> String+camelCaseToDash = foldr go "" . mapFirst C.toLower+ where + go c acc = if C.isUpper c + then '_' : C.toLower c : acc+ else c : acc
+ src/Servant/API/Auth/Token/Internal/Schema.hs view
@@ -0,0 +1,42 @@+{-|+Module : Servant.API.Auth.Token.Internal.Schema+Description : Helpers for swagger deriving without name prefixes.+Copyright : (c) Anton Gushcha, 2016+License : MIT+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : Portable++Common usage:++> data PagedList i a = PagedList {+> pagedListItems :: ![a] -- ^ Payload+> , pagedListPages :: !Word -- ^ Count of available pages+> } deriving (Generic, Show)+> +> instance (ToSchema i, ToSchema a) => ToSchema (PagedList i a) where +> declareNamedSchema = genericDeclareNamedSchema $+> schemaOptionsDropPrefix "pagedList"++-}+module Servant.API.Auth.Token.Internal.Schema(+ schemaOptionsDropPrefix+ ) where ++import Data.Char +import Data.List+import Data.Swagger++-- | Strip given prefix from fields+schemaOptionsDropPrefix :: String -> SchemaOptions+schemaOptionsDropPrefix pr = defaultSchemaOptions {+ fieldLabelModifier = dropPrefix + }+ where + dropPrefix s = case stripPrefix pr s of + Nothing -> s + Just s' -> fixCase s' ++ fixCase x = case x of + [] -> []+ (c:cs) -> toLower c : cs
+ src/Servant/API/Auth/Token/Pagination.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Module : Servant.API.Auth.Token.Pagination+Description : Helpers for response pagination support.+Copyright : (c) Anton Gushcha, 2016+License : MIT+Maintainer : ncrashed@gmail.com+Stability : experimental+Portability : Portable+-}+module Servant.API.Auth.Token.Pagination(+ -- * API types+ PageParam+ , Page+ , PageSizeParam+ , PageSize+ -- ** Helpers+ , PagedList(..)+ ) where ++import Data.Aeson.WithField +import Data.Proxy +import Data.Swagger+import GHC.Generics +import Servant.API+import Servant.API.Auth.Token.Internal.DeriveJson +import Servant.API.Auth.Token.Internal.Schema +import Servant.Docs ++-- | Query parameter that carries pagination page number+type PageParam = QueryParam "page" Page +-- | A page number+type Page = Word ++-- | Query parameter that carries pagination page size value+type PageSizeParam = QueryParam "size" PageSize +-- | Number of items on a page+type PageSize = Word++instance ToParam PageParam where+ toParam _ = DocQueryParam "page" ["0", "42"] "Index of page" Normal++instance ToParam PageSizeParam where+ toParam _ = DocQueryParam "size" ["42", "10"] "Number of elements on page" Normal++-- | Collection of 'a' with attached ids of type 'i' and additional+-- page info.+data PagedList i a = PagedList {+ pagedListItems :: ![WithId i a] -- ^ Payload+, pagedListPages :: !Word -- ^ Count of available pages+} deriving (Generic, Show)+$(deriveJSON (derivePrefix "pagedList") ''PagedList)++instance (ToSchema i, ToSchema a) => ToSchema (PagedList i a) where + declareNamedSchema = genericDeclareNamedSchema $+ schemaOptionsDropPrefix "pagedList"++instance (ToSample i, ToSample a) => ToSample (PagedList i a) where+ toSamples _ = samples $ [s $ toSamples (Proxy :: Proxy (WithId i a))]+ where + s as = PagedList {+ pagedListItems = snd <$> as+ , pagedListPages = 1+ }