diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant-auth-token-api.cabal b/servant-auth-token-api.cabal new file mode 100644 --- /dev/null +++ b/servant-auth-token-api.cabal @@ -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 diff --git a/src/Servant/API/Auth/Token.hs b/src/Servant/API/Auth/Token.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Auth/Token.hs @@ -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' diff --git a/src/Servant/API/Auth/Token/Internal/DeriveJson.hs b/src/Servant/API/Auth/Token/Internal/DeriveJson.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Auth/Token/Internal/DeriveJson.hs @@ -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 diff --git a/src/Servant/API/Auth/Token/Internal/Schema.hs b/src/Servant/API/Auth/Token/Internal/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Auth/Token/Internal/Schema.hs @@ -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 diff --git a/src/Servant/API/Auth/Token/Pagination.hs b/src/Servant/API/Auth/Token/Pagination.hs new file mode 100644 --- /dev/null +++ b/src/Servant/API/Auth/Token/Pagination.hs @@ -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 + }