ucam-webauth-types (empty) → 0.1.0.0
raw patch · 8 files changed
+1651/−0 lines, 8 filesdep +aesondep +basedep +base64-bytestring
Dependencies added: aeson, base, base64-bytestring, bytestring, case-insensitive, containers, deepseq, hspec, http-types, microlens, microlens-mtl, mtl, text, time, timerep
Files
- Changelog.md +14/−0
- LICENSE +203/−0
- README.md +56/−0
- src/Data/ByteString/B64.hs +91/−0
- src/UcamWebauth/Data.hs +605/−0
- src/UcamWebauth/Data/Internal.hs +603/−0
- test/Spec.hs +1/−0
- ucam-webauth-types.cabal +78/−0
+ Changelog.md view
@@ -0,0 +1,14 @@+# Changelog++This changelog is shared among all the packages within the same project.++## 0.1.0.0 - 2018-12-09++Initial versions of `ucam-webauth` and `ucam-webauth-types`.++---++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/).
+ LICENSE view
@@ -0,0 +1,203 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "{}"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright {yyyy} {name of copyright owner}++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+
+ README.md view
@@ -0,0 +1,56 @@+---+title: Ucam Webauth +author: David Baynard +date: 09 Dec 2018 +...++[](https://travis-ci.com/dbaynard/UcamWebauth)++# <https://raven.cam.ac.uk/project/>++The University of Cambridge _Raven_ service uses the _Ucam Webauth_ protocol.++This repository contains a number of Haskell libraries to interact with this system.++# ucam-webauth++[](https://hackage.haskell.org/package/ucam-webauth)+[](http://stackage.org/lts-13/package/ucam-webauth)+[](http://stackage.org/nightly/package/ucam-webauth)++This implements the client authentication protocol; specifically, the validation.++# ucam-webauth-types++[](https://hackage.haskell.org/package/ucam-webauth-types)+[](http://stackage.org/lts-13/package/ucam-webauth-types)+[](http://stackage.org/nightly/package/ucam-webauth-types)++This implements data types for the client authentication protocol.++There is an internal package which is *not* recommended for use.+Its only purpose is to split the core functionality among packages for minimal ghcjs dependencies.++# raven-wai++[](https://hackage.haskell.org/package/raven-wai)+[](http://stackage.org/lts-13/package/raven-wai)+[](http://stackage.org/nightly/package/raven-wai)++This adds [wai](//hackage.haskell.org/package/wai) middleware enabling authentication using _Raven_.++# servant-raven++[](https://hackage.haskell.org/package/servant-raven)+[](http://stackage.org/lts-13/package/servant-raven)+[](http://stackage.org/nightly/package/servant-raven)++API combinators for [servant](//hackage.haskell.org/package/servant), using [servant-auth](//hackage.haskell.org/package/servant-auth).++# servant-raven-server++[](https://hackage.haskell.org/package/servant-raven-server)+[](http://stackage.org/lts-13/package/servant-raven-server)+[](http://stackage.org/nightly/package/servant-raven-server)++The handlers for [servant](//hackage.haskell.org/package/servant).
+ src/Data/ByteString/B64.hs view
@@ -0,0 +1,91 @@+{-|+Module : Data.ByteString.B64+Description : Base 64 ByteStrings (newtypes)+Maintainer : David Baynard <ucamwebauth@baynard.me>+ -}++{-# LANGUAGE+ PackageImports+ , DataKinds+ , DeriveDataTypeable+ , DeriveGeneric+ , DerivingStrategies+ , GeneralizedNewtypeDeriving+ , OverloadedStrings+ , TypeInType+ #-}++module Data.ByteString.B64+ ( Base64UBS(..)+ , Base64UBSL(..)+ , UcamBase64BS(..)+ , UcamBase64BSL(..)+ , ASCII(..)+ ) where++import "deepseq" Control.DeepSeq (NFData)+import "aeson" Data.Aeson.Types+import "bytestring" Data.ByteString (ByteString)+import qualified "bytestring" Data.ByteString.Lazy as BSL+import "base" Data.Data+import "base" Data.String+import "text" Data.Text (Text)+import "text" Data.Text.Encoding+import qualified "text" Data.Text.Lazy.Encoding as TL+import "base" GHC.Generics++------------------------------------------------------------------------------+-- * Text encoding++{-|+ Ensure Base 64 URL text is not confused with other 'ByteString's+-}+newtype Base64UBS (tag :: k) = B64U { unB64U :: ByteString }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++instance FromJSON (Base64UBS tag) where+ parseJSON = withObject "Base 64 URL ByteString" $ \v -> B64U . encodeUtf8+ <$> v .: "Base 64U ByteString"++instance ToJSON (Base64UBS tag) where+ toJSON = toJSON . decodeUtf8 . unB64U+ toEncoding = toEncoding . decodeUtf8 . unB64U++newtype Base64UBSL (tag :: k) = B64UL { unB64UL :: BSL.ByteString }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++instance FromJSON (Base64UBSL tag) where+ parseJSON = withObject "Base 64 URL ByteString" $ \v -> B64UL . TL.encodeUtf8+ <$> v .: "Base 64U ByteString"++instance ToJSON (Base64UBSL tag) where+ toJSON = toJSON . TL.decodeUtf8 . unB64UL+ toEncoding = toEncoding . TL.decodeUtf8 . unB64UL++{-|+ Ensure Base 64 URL text modified to fit the Ucam-Webauth protocol is not confused with other 'ByteString's+-}+newtype UcamBase64BS = UcamB64 { unUcamB64 :: ByteString }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++instance FromJSON UcamBase64BS where+ parseJSON = withObject "Ucam Base 64 URL ByteString" $ \v -> UcamB64 . encodeUtf8+ <$> v .: "Ucam Base 64U ByteString"++instance ToJSON UcamBase64BS where+ toJSON = toJSON . decodeUtf8 . unUcamB64+ toEncoding = toEncoding . decodeUtf8 . unUcamB64++newtype UcamBase64BSL = UcamB64L { unUcamB64L :: BSL.ByteString }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++{-|+ Ensure ASCII text is not confused with other 'ByteString's+-}+newtype ASCII = ASCII { unASCII :: Text }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)
+ src/UcamWebauth/Data.hs view
@@ -0,0 +1,605 @@+{-# LANGUAGE+ PackageImports+ , DataKinds+ , NamedFieldPuns+ , NumDecimals+ , OverloadedLists+ , OverloadedStrings+ , PatternSynonyms+ , RecordWildCards+ , ScopedTypeVariables+ , TupleSections+ , TypeApplications+ , TypeInType+ , TypeOperators+ , ViewPatterns+ #-}++{-|+Module : UcamWebauth.Data+Description : Data types used in Ucam-Webauth protocol+Maintainer : David Baynard <ucamwebauth@baynard.me>++-}++module UcamWebauth.Data+ ( UcamWebauthInfo()+ , approveUniq+ , approveUser+ , approveAttribs+ , approveLife+ , approveParams++ -- $request+ , ucamWebauthQuery++ , AuthRequest()+ , ucamQVer+ , ucamQUrl+ , ucamQDesc+ , ucamQAauth+ , ucamQIact+ , ucamQMsg+ , ucamQParams+ , ucamQDate+ , ucamQFail++ -- $SignedAuthResponse+ , SignedAuthResponse()+ , MaybeValidResponse+ , ValidResponse+ , ucamAResponse+ , ucamAToSign+ , ucamAKid+ , ucamASig++ , AuthResponse()+ , ucamAVer+ , ucamAStatus+ , ucamAMsg+ , ucamAIssue+ , ucamAId+ , ucamAUrl+ , ucamAPrincipal+ , ucamAPtags+ , ucamAAuth+ , ucamASso+ , ucamALife+ , ucamAParams++ -- $typed+ , getAuthInfo++ , WLSVersion(..)+ , displayWLSVersion++ , AuthType(..)+ , displayAuthType++ , Ptag(..)+ , displayPtag++ , StatusCode(..)+ , responseCodes+ , getStatus+ , noAuth510+ , protoErr520+ , paramErr530+ , noInteract540+ , unAuthAgent560+ , declined570++ , YesNo(..)+ , displayYesNo++ , YesOnly(YesOnly)+ , displayYesOnly++ , KeyID()++ , UcamTime()+ , zonedUcamTime+ , ucamTime+ , TimePeriod()+ , secondsFromTimePeriod+ , timePeriodFromSeconds++ , WAAState()+ , wSet+ , aReq++ , WAASettings()+ , SetWAA++ , authAccepted+ , needReauthentication+ , syncTimeOut+ , validKids+ , recentTime+ , applicationUrl+ , wlsUrl+ , importedKeys+ , ucamWebauthHeader++ , Base64UBS()+ , Base64UBSL()+ , UcamBase64BS()+ , UcamBase64BSL()+ , ASCII()+ , convertB64Ucam+ , convertB64UcamL+ , convertUcamB64+ , convertUcamB64L+ , decodeUcamB64+ , decodeUcamB64L+ , encodeUcamB64+ , encodeUcamB64L+ , decodeASCII'++ ) where++import "base" Control.Applicative+import qualified "aeson" Data.Aeson as A (encode)+import "aeson" Data.Aeson.Types (ToJSON)+import "bytestring" Data.ByteString (ByteString)+import "this" Data.ByteString.B64+import qualified "base64-bytestring" Data.ByteString.Base64.URL as B+import qualified "base64-bytestring" Data.ByteString.Base64.URL.Lazy as BL+import "bytestring" Data.ByteString.Builder+import qualified "bytestring" Data.ByteString.Char8 as B+import qualified "bytestring" Data.ByteString.Lazy as BSL+import qualified "bytestring" Data.ByteString.Lazy.Char8 as BL+import qualified "case-insensitive" Data.CaseInsensitive as CI (mk)+import "base" Data.Char (isAlphaNum, isAscii)+import "containers" Data.Map.Strict (Map)+import "base" Data.List.NonEmpty (NonEmpty)+import "base" Data.Maybe (catMaybes)+import "text" Data.Text (Text)+import qualified "text" Data.Text as T+import "text" Data.Text.Encoding+import "time" Data.Time+import "timerep" Data.Time.RFC3339+import "microlens" Lens.Micro+import "microlens-mtl" Lens.Micro.Mtl+import "http-types" Network.HTTP.Types+import "this" UcamWebauth.Data.Internal++------------------------------------------------------------------------------+-- * Lenses++------------------------------------------------------------------------------+-- ** 'UcamWebauthInfo'++{-|+ Unique representation of response, composed of issue and id+-}+approveUniq :: UcamWebauthInfo a `Lens'` (UTCTime, Text)+approveUniq f AuthInfo{..} = (\_approveUniq -> AuthInfo{_approveUniq, ..}) <$> f _approveUniq++{-|+ Identity of authenticated user+-}+approveUser :: UcamWebauthInfo a `Lens'` Text+approveUser f AuthInfo{..} = (\_approveUser -> AuthInfo{_approveUser, ..}) <$> f _approveUser++{-|+ Comma separated attributes of user+-}+approveAttribs :: UcamWebauthInfo a `Lens'` [Ptag]+approveAttribs f AuthInfo{..} = (\_approveAttribs -> AuthInfo{_approveAttribs, ..}) <$> f _approveAttribs++{-|+ Remaining lifetime in seconds of application+-}+approveLife :: UcamWebauthInfo a `Lens'` Maybe TimePeriod+approveLife f AuthInfo{..} = (\_approveLife -> AuthInfo{_approveLife, ..}) <$> f _approveLife++{-|+ A copy of the params from the request+-}+approveParams :: UcamWebauthInfo a `Lens'` Maybe a+approveParams f AuthInfo{..} = (\_approveParams -> AuthInfo{_approveParams, ..}) <$> f _approveParams++------------------------------------------------------------------------------+-- * The request++{-|+ Build a request header to send to the @WLS@, using an 'AuthRequest'+-}+ucamWebauthQuery+ :: ToJSON a+ => SetWAA a+ -> [Header]+ucamWebauthQuery (configWAA -> waa) = catMaybes+ [ location+ , ucamHeader+ ]++ where+ location :: Maybe Header+ location = pure . (hLocation,) . toByteString $ baseUrl waa <> theQuery++ ucamHeader :: Maybe Header+ ucamHeader = (, "1") . CI.mk <$> waa ^. wSet . ucamWebauthHeader++ baseUrl :: WAAState a -> Builder+ baseUrl = encodeUtf8Builder . view (wSet . wlsUrl)++ theQuery :: Builder+ theQuery = renderQueryBuilder True $ strictQs <> textQs <> lazyQs++ strictQs :: Query+ strictQs = toQuery @[(Text, Maybe ByteString)]+ [ ("ver", pure . bsDisplayWLSVersion $ waa ^. aReq . ucamQVer)+ , ("desc", encodeUtf8 . decodeASCII' <$> waa ^. aReq . ucamQDesc)+ , ("iact", bsDisplayYesNo <$> waa ^. aReq . ucamQIact)+ , ("fail", bsDisplayYesOnly <$> waa ^. aReq . ucamQFail)+ ]++ textQs :: Query+ textQs = toQuery @[(Text, Maybe Text)]+ [ ("url" , pure $ waa ^. aReq . ucamQUrl)+ , ("date", unUcamTime . ucamTime <$> waa ^. aReq . ucamQDate)+ , ("aauth", T.intercalate "," . fmap displayAuthType <$> waa ^. aReq . ucamQAauth)+ , ("msg", waa ^. aReq . ucamQMsg)+ ]++ lazyQs :: Query+ lazyQs = toQuery @[(Text, Maybe BSL.ByteString)]+ [ ("params", unUcamB64L . encodeUcamB64L . A.encode <$> waa ^. aReq . ucamQParams)+ ]+ toByteString = BSL.toStrict . toLazyByteString++------------------------------------------------------------------------------+-- ** 'AuthRequest'+{- $request+ The handshake between the @WLS@ and @WAA@ are represented using the 'AuthRequest'+ and 'SignedAuthResponse' data types. The 'AuthResponse' type represents the+ content of a 'SignedAuthResponse'. Constructors and accessors are not exported,+ and the 'AuthRequest' should be build using the smart constructors provided.+-}++{-|+ The version of @WLS.@ 1, 2 or 3.+-}+ucamQVer :: AuthRequest a `Lens'` WLSVersion+ucamQVer f MakeAuthRequest{..} = (\_ucamQVer -> MakeAuthRequest{_ucamQVer, ..}) <$> f _ucamQVer++{-|+ Full http(s) url of resource request for display, and redirection after authentication at the @WLS@++ TODO __This is required__+-}+ucamQUrl :: AuthRequest a `Lens'` Text+ucamQUrl f MakeAuthRequest{..} = (\_ucamQUrl -> MakeAuthRequest{_ucamQUrl, ..}) <$> f _ucamQUrl++{-|+ Description, transmitted as ASCII+-}+ucamQDesc :: AuthRequest a `Lens'` Maybe ASCII+ucamQDesc f MakeAuthRequest{..} = (\_ucamQDesc -> MakeAuthRequest{_ucamQDesc, ..}) <$> f _ucamQDesc++{-|+ Comma delimited sequence of text tokens representing satisfactory authentication methods+-}+ucamQAauth :: AuthRequest a `Lens'` Maybe [AuthType]+ucamQAauth f MakeAuthRequest{..} = (\_ucamQAauth -> MakeAuthRequest{_ucamQAauth, ..}) <$> f _ucamQAauth++{-|+ A token (Yes/No). Yes requires re-authentication. No requires no interaction.+-}+ucamQIact :: AuthRequest a `Lens'` Maybe YesNo+ucamQIact f MakeAuthRequest{..} = (\_ucamQIact -> MakeAuthRequest{_ucamQIact, ..}) <$> f _ucamQIact++{-|+ Why is authentication being requested?+-}+ucamQMsg :: AuthRequest a `Lens'` Maybe Text+ucamQMsg f MakeAuthRequest{..} = (\_ucamQMsg -> MakeAuthRequest{_ucamQMsg, ..}) <$> f _ucamQMsg++{-|+ Data to be returned to the application+-}+ucamQParams :: AuthRequest a `Lens'` Maybe a+ucamQParams f MakeAuthRequest{..} = (\_ucamQParams -> MakeAuthRequest{_ucamQParams, ..}) <$> f _ucamQParams++{-|+ RFC 3339 representation of application’s time+-}+ucamQDate :: AuthRequest a `Lens'` Maybe UTCTime+ucamQDate f MakeAuthRequest{..} = (\_ucamQDate -> MakeAuthRequest{_ucamQDate, ..}) <$> f _ucamQDate++{-|+ Error token. If 'yes', the @WLS@ implements error handling+-}+ucamQFail :: AuthRequest a `Lens'` Maybe YesOnly+ucamQFail f MakeAuthRequest{..} = (\_ucamQFail -> MakeAuthRequest{_ucamQFail, ..}) <$> f _ucamQFail++--------------------------------------------------+-- ** 'SignedAuthResponse'+--------------------------------------------------++{- $SignedAuthResponse+ It is helpful to have type synonyms for valid or otherwise 'SignedAuthRepsonse's.+ -}++type MaybeValidResponse a = SignedAuthResponse 'MaybeValid a++type ValidResponse a = SignedAuthResponse 'Valid a++{-|+ The bit of the response that is signed+-}+ucamAResponse :: SignedAuthResponse valid a `Lens'` AuthResponse a+ucamAResponse f SignedAuthResponse{..} = (\_ucamAResponse -> SignedAuthResponse{_ucamAResponse, ..}) <$> f _ucamAResponse++{-|+ The raw text of the response, used to verify the signature+-}+ucamAToSign :: SignedAuthResponse valid a `Lens'` ByteString+ucamAToSign f SignedAuthResponse{..} = (\_ucamAToSign -> SignedAuthResponse{_ucamAToSign, ..}) <$> f _ucamAToSign++{-|+ RSA key identifier. Must be a string of 1–8 characters, chosen from digits 0–9, with no leading 0, i.e. [1-9][0-9]{0,7}+-}+ucamAKid :: SignedAuthResponse valid a `Lens'` Maybe KeyID+ucamAKid f SignedAuthResponse{..} = (\_ucamAKid -> SignedAuthResponse{_ucamAKid, ..}) <$> f _ucamAKid++{-|+ Required if status is 200, otherwise Nothing. Public key signature of everything up to kid, using the private key identified by kid, the SHA-1 algorithm and RSASSA-PKCS1-v1_5 (PKCS #1 v2.1 RFC 3447), encoded using the base64 scheme (RFC 1521) but with "-._" replacing "+/=" (equivalent to the RFC 4648 with "._" replacing "_=").+-}+ucamASig :: SignedAuthResponse valid a `Lens'` Maybe UcamBase64BS+ucamASig f SignedAuthResponse{..} = (\_ucamASig -> SignedAuthResponse{_ucamASig, ..}) <$> f _ucamASig++--------------------------------------------------+-- ** 'AuthResponse'+--------------------------------------------------++{-|+ The version of @WLS@: 1, 2 or 3+-}+ucamAVer :: AuthResponse a `Lens'` WLSVersion+ucamAVer f AuthResponse{..} = (\_ucamAVer -> AuthResponse{_ucamAVer, ..}) <$> f _ucamAVer++{-|+ 3 digit status code (200 is success)+-}+ucamAStatus :: AuthResponse a `Lens'` StatusCode+ucamAStatus f AuthResponse{..} = (\_ucamAStatus -> AuthResponse{_ucamAStatus, ..}) <$> f _ucamAStatus++{-|+ The status, for users+-}+ucamAMsg :: AuthResponse a `Lens'` Maybe Text+ucamAMsg f AuthResponse{..} = (\_ucamAMsg -> AuthResponse{_ucamAMsg, ..}) <$> f _ucamAMsg++{-|+ RFC 3339 representation of response’s time+-}+ucamAIssue :: AuthResponse a `Lens'` UTCTime+ucamAIssue f AuthResponse{..} = (\_ucamAIssue -> AuthResponse{_ucamAIssue, ..}) <$> f _ucamAIssue++{-|+ Not unguessable identifier, id + issue are unique+-}+ucamAId :: AuthResponse a `Lens'` Text+ucamAId f AuthResponse{..} = (\_ucamAId -> AuthResponse{_ucamAId, ..}) <$> f _ucamAId++{-|+ Same as request+-}+ucamAUrl :: AuthResponse a `Lens'` Text+ucamAUrl f AuthResponse{..} = (\_ucamAUrl -> AuthResponse{_ucamAUrl, ..}) <$> f _ucamAUrl++{-|+ Identity of authenticated user. Must be present if ucamAStatus is 200, otherwise must be Nothing+-}+ucamAPrincipal :: AuthResponse a `Lens'` Maybe Text+ucamAPrincipal f AuthResponse{..} = (\_ucamAPrincipal -> AuthResponse{_ucamAPrincipal, ..}) <$> f _ucamAPrincipal++{-|+ Comma separated attributes of principal. Optional in version 3, must be Nothing otherwise.+-}+ucamAPtags :: AuthResponse a `Lens'` [Ptag]+ucamAPtags f AuthResponse{..} = (\_ucamAPtags -> AuthResponse{_ucamAPtags, ..}) <$> f _ucamAPtags++{-|+ Authentication type if successful, else Nothing+-}+ucamAAuth :: AuthResponse a `Lens'` Maybe AuthType+ucamAAuth f AuthResponse{..} = (\_ucamAAuth -> AuthResponse{_ucamAAuth, ..}) <$> f _ucamAAuth++{-|+ Comma separated list of previous authentications. Required if ucamAAuth is Nothing.+-}+ucamASso :: AuthResponse a `Lens'` Maybe (NonEmpty AuthType)+ucamASso f AuthResponse{..} = (\_ucamASso -> AuthResponse{_ucamASso, ..}) <$> f _ucamASso++{-|+ Remaining lifetime in seconds of application+-}+ucamALife :: AuthResponse a `Lens'` Maybe TimePeriod+ucamALife f AuthResponse{..} = (\_ucamALife -> AuthResponse{_ucamALife, ..}) <$> f _ucamALife++{-|+ A copy of the params from the request+-}+ucamAParams :: AuthResponse a `Lens'` Maybe a+ucamAParams f AuthResponse{..} = (\_ucamAParams -> AuthResponse{_ucamAParams, ..}) <$> f _ucamAParams++{-|+ Takes a validated 'SignedAuthResponse', and returns the corresponding 'UcamWebauthInfo'.+-}+getAuthInfo :: Alternative f => SignedAuthResponse 'Valid a -> f (UcamWebauthInfo a)+getAuthInfo = extractAuthInfo . _ucamAResponse++------------------------------------------------------------------------------+-- * Typed representations of protocol data+{- $typed+ These types represent data such as the protocol version ('WLSVersion') that is + inherently typed but has a string representation in the protocol+-}++------------------------------------------------------------------------------+-- *** Time++{-|+ Convert the protocol time representation to a 'UTCTime', based on the 'utc' time zone.+-}+zonedUcamTime :: UcamTime -> Maybe ZonedTime+zonedUcamTime = parseTimeRFC3339 . unUcamTime++{-|+ Convert a 'UTCTime' to the protocol time representation, based on the 'utc' time zone.+-}+ucamTime :: UTCTime -> UcamTime+ucamTime = UcamTime . T.filter isAlphaNum . formatTimeRFC3339 . utcToZonedTime utc++------------------------------------------------------------------------------+-- * 'WAASettings' and lenses++wSet :: WAAState a `Lens'` WAASettings+wSet f MakeWAAState{..} = (\_wSet -> MakeWAAState{_wSet, ..}) <$> f _wSet++aReq :: WAAState a `Lens'` AuthRequest a+aReq f MakeWAAState{..} = (\_aReq -> MakeWAAState{_aReq, ..}) <$> f _aReq++{-|+ Accepted authentication types by the protocol.++ Default @['Pwd']@+-}+authAccepted :: WAASettings `Lens'` [AuthType]+authAccepted f MakeWAASettings{..} = (\_authAccepted -> MakeWAASettings{_authAccepted, ..}) <$> f _authAccepted++{-|+ 'Just' 'True' means ‘must reauthenticate’, 'Just' 'False' means ‘non-interactive’, 'Nothing' means anything goes.++ Default 'Nothing'+-}+needReauthentication :: WAASettings `Lens'` Maybe YesNo+needReauthentication f MakeWAASettings{..} = (\_needReauthentication -> MakeWAASettings{_needReauthentication, ..}) <$> f _needReauthentication++{-|+ A timeout for the response validation.++ Default @40@ (seconds)+-}+syncTimeOut :: WAASettings `Lens'` NominalDiffTime+syncTimeOut f MakeWAASettings{..} = (\_syncTimeOut -> MakeWAASettings{_syncTimeOut, ..}) <$> f _syncTimeOut++{-|+ Valid 'KeyID' values for the protocol.++ Default @[]@ (/i.e./ no valid keys)+-}+validKids :: WAASettings `Lens'` [KeyID]+validKids f MakeWAASettings{..} = (\_validKids -> MakeWAASettings{_validKids, ..}) <$> f _validKids++{-|+ The last time something interesting happened. With an interesting definition of interesting.++ Default is the start of 'UTCTime'.++ TODO Document when this is updated, here.+-}+recentTime :: WAASettings `Lens'` UTCTime+recentTime f MakeWAASettings{..} = (\_recentTime -> MakeWAASettings{_recentTime, ..}) <$> f _recentTime++{-|+ The url to be transmitted to the @WLS@ is the url to which it redirects the + user’s browser after the submission, and the url which it displays to the user+ (in the case of Raven).++ TODO Default is empty. The implementation __must__ override it.+-}+applicationUrl :: WAASettings `Lens'` Text+applicationUrl f MakeWAASettings{..} = (\_applicationUrl -> MakeWAASettings{_applicationUrl, ..}) <$> f _applicationUrl++{-|+ The url to be transmitted to the @WLS@ is the url to which it redirects the + user’s browser after the submission, and the url which it displays to the user+ (in the case of Raven).++ TODO Default is empty. The implementation __must__ override it.+-}+wlsUrl :: WAASettings `Lens'` Text+wlsUrl f MakeWAASettings{..} = (\_wlsUrl -> MakeWAASettings{_wlsUrl, ..}) <$> f _wlsUrl++{-|+ Rather than acquiring the keys from a static directory, it is possible to supply+ the key data during compilation; these are stored in a map, here.++ Defaults to an empty map.+-}+importedKeys :: WAASettings `Lens'` Map KeyID ByteString+importedKeys f MakeWAASettings{..} = (\_importedKeys -> MakeWAASettings{_importedKeys, ..}) <$> f _importedKeys++{-|+ We may need to pass a custom header to identify the redirect to a javascript client.+ The header name is contained here (the value is set to '1').++ Default is empty, which should be implemented to correspond to no header.++-}+ucamWebauthHeader :: WAASettings `Lens'` Maybe ByteString+ucamWebauthHeader f MakeWAASettings{..} = (\_ucamWebauthHeader -> MakeWAASettings{_ucamWebauthHeader, ..}) <$> f _ucamWebauthHeader++------------------------------------------------------------------------------+-- * Text encoding++{-|+ Convert to the protocol’s version of base64+-}+convertB64Ucam :: Base64UBS tag -> UcamBase64BS+convertB64Ucam = UcamB64 . B.map camEncodeFilter . unB64U++convertB64UcamL :: Base64UBSL tag -> UcamBase64BSL+convertB64UcamL = UcamB64L . BL.map camEncodeFilter . unB64UL++camEncodeFilter :: Char -> Char+camEncodeFilter '_' = '.'+camEncodeFilter '=' = '_'+camEncodeFilter x = x++{-|+ Convert from the protocol’s version of base64+-}+convertUcamB64 :: UcamBase64BS -> Base64UBS tag+convertUcamB64 = B64U . B.map camDecodeFilter . unUcamB64++convertUcamB64L :: UcamBase64BSL -> Base64UBSL tag+convertUcamB64L = B64UL . BL.map camDecodeFilter . unUcamB64L++camDecodeFilter :: Char -> Char+camDecodeFilter '.' = '_'+camDecodeFilter '_' = '='+camDecodeFilter x = x++{-|+ This uses 'B.decodeLenient' internally.++ TODO It should not be a problem, if operating on validated input, but might be worth testing (low priority).+-}+decodeUcamB64 :: UcamBase64BS -> ByteString+decodeUcamB64 = B.decodeLenient . unB64U . convertUcamB64++decodeUcamB64L :: UcamBase64BSL -> BSL.ByteString+decodeUcamB64L = BL.decodeLenient . unB64UL . convertUcamB64L++{-|+ Unlike decoding, this is fully pure.+-}+encodeUcamB64 :: ByteString -> UcamBase64BS+encodeUcamB64 = convertB64Ucam . B64U . B.encode++encodeUcamB64L :: BSL.ByteString -> UcamBase64BSL+encodeUcamB64L = convertB64UcamL . B64UL . BL.encode++{-|+ Extract ascii text.++ TODO Use Haskell’s utf7 functions+-}+decodeASCII' :: ASCII -> Text+decodeASCII' = T.filter isAscii . unASCII
+ src/UcamWebauth/Data/Internal.hs view
@@ -0,0 +1,603 @@+{-# OPTIONS_HADDOCK hide, not_here #-}+{-# LANGUAGE+ PackageImports+ , DataKinds+ , DeriveAnyClass+ , DeriveDataTypeable+ , DeriveGeneric+ , DerivingStrategies+ , GeneralizedNewtypeDeriving+ , NamedFieldPuns+ , NumDecimals+ , OverloadedLists+ , OverloadedStrings+ , PatternSynonyms+ , RecordWildCards+ , TypeInType+ , TypeOperators+ #-}++{-|+Module : UcamWebauth.Internal+Description : Internal use for Ucam Webauth data types+Maintainer : David Baynard <ucamwebauth@baynard.me>++This module is *not* for general use.+It is *not* considered part of the API.+The only purpose is to allow core functionality to be split among various packages.++Versions will not reflect changes to the API of this module.++-}++module UcamWebauth.Data.Internal+ ( UcamWebauthInfo(..)++ , AuthRequest(..)++ , SignedAuthResponse(..)++ , IsValid(..)++ , AuthResponse(..)++ , extractAuthInfo++ , WLSVersion(..)+ , displayWLSVersion+ , bsDisplayWLSVersion++ , AuthType(..)+ , displayAuthType++ , Ptag(..)+ , displayPtag++ , StatusCode(..)+ , responseCodes+ , getStatus+ , noAuth510+ , protoErr520+ , paramErr530+ , noInteract540+ , unAuthAgent560+ , declined570++ , YesNo(..)+ , displayYesNo+ , bsDisplayYesNo++ , YesOnly(YesOnly)+ , displayYesOnly+ , bsDisplayYesOnly++ , KeyID(..)++ , UcamTime(..)+ , TimePeriod(..)+ , secondsFromTimePeriod+ , timePeriodFromSeconds++ , WAAState(..)++ , WAASettings(..)+ , SetWAA+ , configWAA+ ) where++import "base" Control.Applicative+import "base" Control.Arrow ((&&&))+import "deepseq" Control.DeepSeq (NFData, NFData1)+import "mtl" Control.Monad.State+import "aeson" Data.Aeson.Types+import "bytestring" Data.ByteString (ByteString)+import "this" Data.ByteString.B64+import "base" Data.Char (toLower, isDigit)+import "base" Data.Data+import "containers" Data.IntMap (IntMap)+import qualified "containers" Data.IntMap as IntMap+import "base" Data.List.NonEmpty (NonEmpty)+import "containers" Data.Map.Strict (Map)+import qualified "containers" Data.Map.Strict as MapS+import "base" Data.Maybe (fromMaybe)+import "base" Data.String+import "text" Data.Text (Text)+import "text" Data.Text.Encoding+import "text" Data.Text.Encoding.Error+import "time" Data.Time+import "base" GHC.Generics+import "http-types" Network.HTTP.Types++------------------------------------------------------------------------------+-- * Core data types and associated functions++------------------------------------------------------------------------------+-- ** Return type++{-|+ 'UcamWebauthInfo' is returned from this module. The parameter 'a' represents data sent+ in the initial connection, that must be returned. The constructor and accessors are *not*+ exported from the module, to present an abstract API.+-}+data UcamWebauthInfo a = AuthInfo+ { _approveUniq :: (UTCTime, Text)+ , _approveUser :: Text+ , _approveAttribs :: [Ptag]+ , _approveLife :: Maybe TimePeriod+ , _approveParams :: Maybe a+ }+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)+ deriving anyclass (NFData, NFData1)++instance ToJSON a => ToJSON (UcamWebauthInfo a)+instance FromJSON a => FromJSON (UcamWebauthInfo a)++------------------------------------------------------------------------------+-- ** Request and response+{- $request+ The handshake between the @WLS@ and @WAA@ are represented using the 'AuthRequest'+ and 'SignedAuthResponse' data types. The 'AuthResponse' type represents the+ content of a 'SignedAuthResponse'. Constructors and accessors are not exported,+ and the 'AuthRequest' should be build using the smart constructors provided.+-}++{-|+ An 'AuthRequest' is constructed by the @WAA@, using the constructor functions+ of this module. The parameter represents data to be returned to the application+ after authentication.+-}+data AuthRequest a = MakeAuthRequest+ { _ucamQVer :: WLSVersion+ , _ucamQUrl :: Text+ , _ucamQDesc :: Maybe ASCII+ , _ucamQAauth :: Maybe [AuthType]+ , _ucamQIact :: Maybe YesNo+ , _ucamQMsg :: Maybe Text+ , _ucamQParams :: Maybe a+ , _ucamQDate :: Maybe UTCTime+ , _ucamQFail :: Maybe YesOnly+ }+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)+ deriving anyclass (NFData, NFData1)++{-|+ A 'SignedAuthResponse' represents the data returned by the @WLS@, including a+ representation of the content returned (in the 'AuthResponse' data type), and+ the cryptographic signature, for verification.++ The phantom parameter 'valid' corr+-}+data SignedAuthResponse (valid :: IsValid) a = SignedAuthResponse+ { _ucamAResponse :: AuthResponse a+ , _ucamAToSign :: ByteString+ , _ucamAKid :: Maybe KeyID+ , _ucamASig :: Maybe UcamBase64BS+ }+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)+ deriving anyclass (NFData, NFData1)++{-|+ The intended use of this is with 'IsValid' as a kind (requires the 'DataKinds' extension).+ The data constructors 'Valid' and 'MaybeValid' are now type constructors, which indicate the+ validity of a 'SignedAuthResponse'.++ This is not exported.+-}+data IsValid+ = MaybeValid+ | Valid+ deriving stock (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++{-|+ An 'AuthResponse' represents the content returned by the @WLS@. The validation+ machinery in this module returns the required data as a 'UcamWebauthInfo' value.+-}+data AuthResponse a = AuthResponse+ { _ucamAVer :: WLSVersion+ , _ucamAStatus :: StatusCode+ , _ucamAMsg :: Maybe Text+ , _ucamAIssue :: UTCTime+ , _ucamAId :: Text+ , _ucamAUrl :: Text+ , _ucamAPrincipal :: Maybe Text+ , _ucamAPtags :: [Ptag]+ , _ucamAAuth :: Maybe AuthType+ , _ucamASso :: Maybe (NonEmpty AuthType)+ , _ucamALife :: Maybe TimePeriod+ , _ucamAParams :: Maybe a+ }+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)+ deriving anyclass (NFData, NFData1)++{-|+ Convert an 'AuthResponse' into a 'UcamWebauthInfo' for export.++ This should not be exported. Instead export 'getAuthInfo'+-}+extractAuthInfo :: Alternative f => AuthResponse a -> f (UcamWebauthInfo a)+extractAuthInfo AuthResponse{..} = maybe empty pure $ do+ _approveUser <- _ucamAPrincipal+ return AuthInfo{..}+ where+ _approveUniq = (_ucamAIssue, _ucamAId)+ _approveAttribs = _ucamAPtags+ _approveLife = _ucamALife+ _approveParams = _ucamAParams++------------------------------------------------------------------------------+-- *** Protocol version++{-|+ Intended to be used as values, but Kind promotion means they can be used as types.+-}+data WLSVersion+ = WLS1 -- ^ Version 1 of the protocol. In the Raven implementation, failures use this version+ | WLS2 -- ^ Version 2+ | WLS3 -- ^ Version 3. Used for successful reponses by the Raven implementation+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++instance Show WLSVersion where+ show = displayWLSVersion++{-|+ Used for 'Show' instance.+-}+displayWLSVersion :: IsString a => WLSVersion -> a+displayWLSVersion WLS1 = "1"+displayWLSVersion WLS2 = "2"+displayWLSVersion WLS3 = "3"++{-|+ Like the 'Show' instance, but typed to 'ByteString'.++-}+bsDisplayWLSVersion :: WLSVersion -> ByteString+bsDisplayWLSVersion = displayWLSVersion++wlsVersionAesonOptions :: Options+wlsVersionAesonOptions = defaultOptions+ { constructorTagModifier = drop 3+ , sumEncoding = ObjectWithSingleField+ }++instance FromJSON WLSVersion where+ parseJSON = genericParseJSON wlsVersionAesonOptions++instance ToJSON WLSVersion where+ toJSON = genericToJSON wlsVersionAesonOptions+ toEncoding = genericToEncoding wlsVersionAesonOptions++------------------------------------------------------------------------------+-- *** Authentication types available++{-|+ An enumeration of valid authentication types. The protocol currently only defines one+ valid type.+-}+data AuthType+ = Pwd -- ^ pwd: Username and password+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++instance Show AuthType where+ show = displayAuthType++{-|+ Implement show generically+-}+displayAuthType :: IsString a => AuthType -> a+displayAuthType Pwd = "pwd"++instance FromJSON AuthType where+ parseJSON = genericParseJSON enumAesonOptions++instance ToJSON AuthType where+ toJSON = genericToJSON enumAesonOptions+ toEncoding = genericToEncoding enumAesonOptions++enumAesonOptions :: Options+enumAesonOptions = defaultOptions+ { constructorTagModifier = fmap toLower+ , sumEncoding = UntaggedValue+ , tagSingleConstructors = True+ }++------------------------------------------------------------------------------+-- *** Data possibly useful for authorization (ptags)++{-|+ This is only in protocol versions ≥ 3+-}+data Ptag+ = Current -- ^ User is current member of university+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++instance Show Ptag where+ show = displayPtag++{-|+ Generic 'Show' implementation+-}+displayPtag :: IsString a => Ptag -> a+displayPtag Current = "current"++instance FromJSON Ptag where+ parseJSON = genericParseJSON enumAesonOptions++instance ToJSON Ptag where+ toJSON = genericToJSON enumAesonOptions+ toEncoding = genericToEncoding enumAesonOptions++------------------------------------------------------------------------------+-- *** HTTP response codes+{- $statusCodes+ A data type representing the HTTP status codes in the protocol. This is compatible+ with the 'Status' type, but using the algebraic data type makes working with it+ a little nicer.+-}++{-|+ The valid HTTP status codes, according to the protocol.++ 'BadRequest400' is present as a default, if there is any other code received.+-}+data StatusCode+ = Ok200 -- ^ Authentication successful+ | Gone410 -- ^ Cancelled by the user+ | NoAuth510 -- ^ No mutually acceptable authentication types+ | ProtoErr520 -- ^ Unsupported protocol version (Only for version 1)+ | ParamErr530 -- ^ General request parameter error+ | NoInteract540 -- ^ Interaction would be required but has been blocked+ | UnAuthAgent560 -- ^ Application agent is not authorised+ | Declined570 -- ^ Authentication declined+ | BadRequest400 -- ^ Response not covered by any protocol responses+ deriving stock (Show, Read, Eq, Ord, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++instance Enum StatusCode where+ toEnum = fromMaybe BadRequest400 . flip IntMap.lookup responseCodes+ fromEnum = statusCode . getStatus++statusCodeAesonOptions :: Options+statusCodeAesonOptions = defaultOptions+ { constructorTagModifier = dropWhile (not . isDigit)+ , sumEncoding = ObjectWithSingleField+ }++instance FromJSON StatusCode where+ parseJSON = genericParseJSON statusCodeAesonOptions++instance ToJSON StatusCode where+ toJSON = genericToJSON statusCodeAesonOptions+ toEncoding = genericToEncoding statusCodeAesonOptions+++{-|+ An 'IntMap' of 'Status' code numbers in the protocol to their typed representations.+-}+responseCodes :: IntMap StatusCode+responseCodes = IntMap.fromList . fmap (statusCode . getStatus &&& id) $+ [Ok200, Gone410, NoAuth510, ProtoErr520, ParamErr530, NoInteract540, UnAuthAgent560, Declined570]++{-|+ Convert to the 'Status' type, defaulting to 'badRequest400' for a bad request+-}+getStatus :: StatusCode -> Status+getStatus Ok200 = ok200+getStatus Gone410 = gone410+getStatus NoAuth510 = noAuth510+getStatus ProtoErr520 = protoErr520+getStatus ParamErr530 = paramErr530+getStatus NoInteract540 = noInteract540+getStatus UnAuthAgent560 = unAuthAgent560+getStatus Declined570 = declined570+getStatus _ = badRequest400++------------------------------------------------------------------------------+-- *** 'Status' values++noAuth510, protoErr520, paramErr530, noInteract540, unAuthAgent560, declined570 :: Status+noAuth510 = mkStatus 510 "No mutually acceptable authentication types"+protoErr520 = mkStatus 520 "Unsupported protocol version (Only for version 1)"+paramErr530 = mkStatus 530 "General request parameter error"+noInteract540 = mkStatus 540 "Interaction would be required but has been blocked"+unAuthAgent560 = mkStatus 560 "Application agent is not authorised"+declined570 = mkStatus 570 "Authentication declined"++------------------------------------------------------------------------------+-- *** iact yes or no++{-|+ This is like a Boolean, but specifically for the ‘iact’ parameter+-}+data YesNo+ = No+ | Yes+ deriving stock (Read, Eq, Ord, Enum, Bounded, Generic, Typeable, Data)+ deriving anyclass (NFData)++instance Show YesNo where+ show = displayYesNo++displayYesNo :: IsString a => YesNo -> a+displayYesNo Yes = "yes"+displayYesNo _ = "no"++{-|+ Monomorphic variant of 'displayYesNo'+-}+bsDisplayYesNo :: YesNo -> ByteString+bsDisplayYesNo = displayYesNo++------------------------------------------------------------------------------+-- *** fail yes++{-|+ Like '()' but specifically for the ‘iact’ parameter+-}+newtype YesOnly = YesOnly' ()+ deriving stock (Read, Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Enum, Bounded, NFData)++pattern YesOnly :: YesOnly+pattern YesOnly = YesOnly' ()++{-# COMPLETE YesOnly #-}++instance Show YesOnly where+ show = displayYesOnly++displayYesOnly :: IsString a => YesOnly -> a+displayYesOnly YesOnly = "yes"++{-|+ Monomorphic variant of 'displayYesOnly'+-}+bsDisplayYesOnly :: YesOnly -> ByteString+bsDisplayYesOnly = displayYesOnly++------------------------------------------------------------------------------+-- *** Keys++{-|+ The key id, representing the public key for the @WLS@, is composed of a subset of 'ByteString' identifiers++ Do not export constructors+-}+newtype KeyID = KeyID { unKeyID :: ByteString }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++instance FromJSON KeyID where+ parseJSON = withObject "Key ID" $ \v -> KeyID . encodeUtf8+ <$> v .: "Ucam Base 64U ByteString"++instance ToJSON KeyID where+ toJSON = toJSON . decodeUtf8With lenientDecode . unKeyID+ toEncoding = toEncoding . decodeUtf8With lenientDecode . unKeyID++------------------------------------------------------------------------------+-- *** Time++{-|+ The modified UTCTime representation used in the protocol, based on RFC 3339. All+ time zones are 'utc'.++ Do not export constructor or accessor.+-}+newtype UcamTime = UcamTime { unUcamTime :: Text }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Read, IsString, Monoid, Semigroup, NFData)++{-|+ 'DiffTime' with 'ToJSON' and 'FromJSON' instances.+-}+newtype TimePeriod = TimePeriod { timePeriod :: DiffTime }+ deriving stock (Eq, Ord, Generic, Typeable, Data)+ deriving newtype (Show, Num, NFData)++secondsFromTimePeriod :: TimePeriod -> Integer+secondsFromTimePeriod = round . timePeriod++timePeriodFromSeconds :: Integer -> TimePeriod+timePeriodFromSeconds = TimePeriod . secondsToDiffTime++instance ToJSON TimePeriod where+ toJSON = toJSON . secondsFromTimePeriod+ toEncoding = toEncoding . secondsFromTimePeriod++instance FromJSON TimePeriod where+ parseJSON = withObject "Seconds" $ \v -> timePeriodFromSeconds+ <$> v .: "Seconds"++------------------------------------------------------------------------------+-- * 'WAASettings' and lenses++{-|+ The state involved in authentication. This includes the settings as 'WAASettings' and + the request as 'AuthRequest'.++ Do not export constructors or accessors, only lenses.+-}+data WAAState a = MakeWAAState+ { _wSet :: WAASettings+ , _aReq :: AuthRequest a+ --, _aSrs :: SignedAuthResponse valid a+ }+ deriving stock (Show, Eq, Ord, Generic, Generic1, Typeable, Data)+ deriving anyclass (NFData, NFData1)++{-|+ The settings for the application.++ Do not export constructors or accessors, only lenses.+ TODO Make urls type safe+-}+data WAASettings = MakeWAASettings+ { _authAccepted :: [AuthType]+ , _needReauthentication :: Maybe YesNo+ , _syncTimeOut :: NominalDiffTime+ , _validKids :: [KeyID]+ , _recentTime :: UTCTime+ , _applicationUrl :: Text+ , _wlsUrl :: Text+ , _importedKeys :: Map KeyID ByteString+ , _ucamWebauthHeader :: Maybe ByteString+ }+ deriving stock (Show, Eq, Ord, Generic, Typeable, Data)+ deriving anyclass (NFData)++{-|+ Type synonym for WAASettings settings type.+-}+type SetWAA a = State (WAAState a) ()++{-|+ The default @WAA@ settings. To accept the defaults, use++ > configWAA def++ or++ > configWAA . return $ ()++ To modify settings, use the provided lenses.++ 'configWAA' should not be exported. Instead, all functions requiring settings+ should use this function in a view pattern.+-}+configWAA :: SetWAA a -> WAAState a+configWAA = flip execState MakeWAAState+ { _wSet = settings+ , _aReq = request+ }++ where+ settings :: WAASettings+ settings = MakeWAASettings+ { _authAccepted = [Pwd]+ , _needReauthentication = Nothing+ , _syncTimeOut = 40+ , _validKids = empty+ , _recentTime = error "You must assign a time to check the issue time of a response is valid."+ , _applicationUrl = mempty+ , _wlsUrl = error "You must enter a URL for the authentication server."+ , _importedKeys = MapS.empty+ , _ucamWebauthHeader = empty+ }++ request :: AuthRequest a+ request = MakeAuthRequest+ { _ucamQVer = WLS3+ , _ucamQUrl = error "You must enter a URL for the application wishing to authenticate the user."+ , _ucamQDesc = pure "This should be the ASCII description of the application requesting authentication"+ , _ucamQAauth = empty+ , _ucamQIact = empty+ , _ucamQMsg = pure "This should be the reason authentication is requested."+ , _ucamQParams = empty+ , _ucamQDate = empty+ , _ucamQFail = pure YesOnly+ }
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ ucam-webauth-types.cabal view
@@ -0,0 +1,78 @@+cabal-version: 2.2+name: ucam-webauth-types+version: 0.1.0.0+license: (BSD-3-Clause OR Apache-2.0)+license-file: LICENSE+copyright: 2018 David Baynard+maintainer: David Baynard <ucamwebauth@baynard.me>+author: David Baynard <ucamwebauth@baynard.me>+homepage: https://github.com/dbaynard/UcamWebauth#readme+bug-reports: https://github.com/dbaynard/UcamWebauth/issues+synopsis: Types for the Ucam-Webauth protocol, as used by Raven+description:+ Types for the implementation of the Ucam-Webauth protocol, as used by the+ University of Cambridge’s Raven authentication service.+category: Web+build-type: Simple+extra-source-files:+ Changelog.md+ README.md++source-repository head+ type: git+ location: https://github.com/dbaynard/UcamWebauth++flag dev+ description:+ Compile for development+ default: False+ manual: True++library+ exposed-modules:+ Data.ByteString.B64+ UcamWebauth.Data+ UcamWebauth.Data.Internal+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances+ -Wnoncanonical-monadfail-instances+ build-depends:+ aeson >=1.2 && <1.5,+ base >=4.11.0.0 && <4.12,+ base64-bytestring >=1.0.0.1 && <1.1,+ bytestring >=0.10.8.2 && <0.11,+ case-insensitive >=1.2.0.11 && <1.3,+ containers >=0.5.11.0 && <0.6,+ deepseq >=1.4.3.0 && <1.5,+ http-types >=0.12.1 && <0.13,+ microlens >=0.4.9.1 && <0.5,+ microlens-mtl >=0.1.11.1 && <0.2,+ mtl >=2.2.2 && <2.3,+ text >=0.11 && <1.2.3.0 || >=1.2.3.1 && <1.3,+ time >=1.9.2 && <1.10,+ timerep >=2.0.0.2 && <2.1+ + if flag(dev)+ ghc-options: -ddump-minimal-imports++test-suite test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover -any+ hs-source-dirs: test+ other-modules:+ Paths_ucam_webauth_types+ autogen-modules:+ Paths_ucam_webauth_types+ default-language: Haskell2010+ ghc-options: -Wall -Wincomplete-uni-patterns+ -Wincomplete-record-updates -Wcompat -Wnoncanonical-monad-instances+ -Wnoncanonical-monadfail-instances+ build-depends:+ base >=4.11.0.0 && <4.12,+ hspec >=2.0.0 && <2.6+ + if flag(dev)+ ghc-options: -ddump-minimal-imports